perm filename PARSE.OLD[HAL,HE]1 blob
sn#239241 filedate 1976-09-27 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00061 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00005 00002 the AL to S-expression translator
C00009 00003 ! reserved word classes
C00011 00004
C00013 00005 ! miscellaneous reserved words
C00014 00006 ! dec_name, declaration names for input and output
C00016 00007 ! operators
C00028 00008 ! reserved_words
C00034 00009 ! init_reserved
C00036 00010 ! predefined constants
C00038 00011 ! compiler switches and control tables
C00041 00012 ! hash, declaration of debugging variables, start of hidden_parse
C00044 00013 ! ---- DECLARATIONS ----
C00050 00014
C00053 00015
C00056 00016 ! error, error_reject, print, file_indent
C00061 00017 ! read, push_macro_delimiters
C00068 00018 ! mac_test_and_expand
C00072 00019 ! get_token
C00076 00020 ! look for reserved word
C00079 00021 ! check
C00081 00022 ! combine
C00085 00023 ! reduce, tmake_R
C00088 00024 ! vmake_R, fmake_R
C00092 00025 ! vvtrans_R, sneg_R
C00096 00026 ! rinv_R, sabs_R
C00098 00027 ! plus_R
C00101 00028 ! minus_R
C00103 00029 ! times_R
C00107 00030 ! rot_R, wrt_R
C00110 00031 ! →_R
C00113 00032 ! reduce execution starts here
C00118 00033 ! printexpr
C00119 00034 ! p_exp2
C00121 00035 ! parse_special
C00129 00036 ! p_exp2 execution begins here, p_exp
C00142 00037 ! P_condition
C00145 00038 ! P_clauses, T_gen
C00155 00039 ! P_statement, begin_P
C00158 00040 ! cobegin_P, end_P, open_paren_P
C00162 00041 ! declare_P
C00165 00042 ! global_P
C00169 00043 ! if_P, plan_P, while_P
C00172 00044 ! for_P
C00174 00045 ! move_P
C00176 00046 ! affix_p
C00180 00047 ! unfix_P, signal_P
C00183 00048 ! wait_P
C00184 00049 ! when_P
C00187 00050 ! dump_P
C00189 00051 ! assert_P
C00193 00052 ! on_P, reference_P, parseshit_P, open_P
C00197 00053 ! center_P, stop_P
C00198 00054 ! define_P
C00204 00055 ! require_P
C00209 00056 ! dimension_P
C00214 00057 ! abort_P
C00216 00058 ! P_statement execution starts here
C00223 00059 ! execution starts here
C00225 00060 ! set up input and output
C00235 00061 ! set up predefined constants and variables
C00239 ENDMK
C⊗;
comment the AL to S-expression translator;
Begin "PARSE"
REQUIRE 1024 STRING_PDL; REQUIRE 1024 STRING_SPACE; REQUIRE 1024 SYSTEM_PDL;
require "[][]" delimiters;
define
α =[begin],
β =[end],
! =[comment],
tab ='11,
lf ='12,
ff ='14,
cr ='15,
space ='40,
dquote ='42,
rubout ='177,
crlf =[('15&'12)],
hasher =256,
preload_array(name, defs, type, first, len)=[
preload_with defs null; type array name[first:first+len] ];
! N.B. -- preload_array always creates an array 1 longer than requested;
! if /nB is set in the command line then assume he wants a debugging parser;
require "<><>" delimiters;
ifc ¬declaration(debug_compile) thenc
define
decipher_debug(a)=<
assignc a=cvms(compiler!banner)[2 to ∞-1];
assignc a=cvps(a)[length(scanc(cvps(a), lf, null, "IA"))+1 for ∞];
assignc a=cvps(a)[length(scanc(cvps(a), tab, null, "IA"))+1 for ∞];
assignc a=cvps(a)[length(scanc(cvps(a), space, null, "IA"))+1 for 1];
"a">;
ifc decipher_debug()="0"
thenc define debug_compile=false;
elsec define debug_compile=true;
endc
endc
require unstack_delimiters;
require ifc ¬debug_compile
thenc " NON-" elsec " " endc & "DEBUGGING VERSION " message;
ifc debug_compile thenc EXTERNAL PROCEDURE BAIL; endc
define
indices(name, postfix)=[
redefine xxcount=0;
redefine xx(xxarg)=[
redefine xxtemp=[define xxarg] & [postfix=xxcount];
xxtemp;
redefine xxcount=xxcount+1;];
name];
! ID postfix conventions
_VALUE AL data types
_RES reserved word types
_beg reserved word group begin
_end reserved word group end
_R REDUCE action routines
_P PARSE action routines
_TOKEN scanner token types
_CM condition monitors
_X indices of various sorts
_METRIC dimensional analysis non-sense
_DIMEN how to combine various matrix operands
;
! **********; require "SNAILR[HAL,HE]" source_file; ! **********;
! reserved word classes;
redefine xx(str)=[
redefine reserved_X_count=reserved_X_count+1;
redefine xx_temp="define " & "str" & "_RES=reserved_X_count";
xx_temp;];
define statement_definitions=[
XX(BEGIN)
XX(COBEGIN)
XX(END) ! also includes semicolon and COEND;
XX(OPEN_PAREN)
XX(DECLARE)
XX(GLOBAL)
XX(IF)
XX(PLAN)
XX(WHILE)
XX(FOR)
XX(MOVE)
XX(AFFIX)
XX(UNFIX)
XX(SIGNAL)
XX(WAIT)
XX(WHEN)
XX(DUMP)
XX(ASSERT) ! also DENY;
XX(ON)
XX(REFERENCE)
XX(PARSESHIT)
XX(OPEN) ! also CLOSE;
XX(CENTER)
XX(STOP)
XX(DEFINE)
XX(REQUIRE)
XX(DIMENSION) ! also COMMENT;
XX(ABORT) ! also PRINT;
];
define operator_classes=[
xx(comma) ! order of this group determines arithmetic precedence;
xx(or)
xx(and)
xx(not)
xx(order)
xx(abs)
xx(add)
xx(mult)
xx(trans)
xx(vector)
xx(close_paren)
];
define require_definitions=[
xx(SOURCE_FILE)
xx(DELIMITERS)
xx(UNSTACK_DELIMITERS)
xx(REPLACE_DELIMITERS)
];
define move_definitions=[
xx(VIA)
xx(WITH)
xx(ARRIVAL)
];
! All reserved word class id's have a postfix of "_RES". The fact that the parser
groups clases together is reflected by the definition of id's with "_beg" and
"_end" postfixes. The code demands that misc_RES be 0;
define
brace_RES =-1,
misc_RES =0,
cm_RES =0,
reserved_X_count=0,
statement_beg =reserved_X_count+1;
statement_definitions;
define
statement_end =reserved_X_count,
operator_beg =reserved_X_count+1;
operator_classes;
define
operator_end =reserved_X_count,
move_beg =reserved_X_count+1;
move_definitions;
define
move_end =reserved_X_count,
require_beg =reserved_X_count+1;
require_definitions;
define
require_end =reserved_X_count+1;
XX(METRIC) ! TIME, DISTANCE, etc.;
indices(require_definitions, _X);
indices(move_definitions, _X);
! miscellaneous reserved words;
define metric_definitions=[
xx(nil)
xx(DISTANCE)
xx(TIME)
xx(MASS)
xx(ANGLE)
];
indices(metric_definitions, _METRIC);
define
metric_max =xxcount-1;
! condition monitors;
define cm_definitions=[
xx(nil)
xx(FORCE)
xx(TORQUE)
xx(FORCE_OR_TORQUE)
xx(DURATION) ! this and subsequent entries are zero in reserved words;
xx(TEMPERATURE)
xx(SQUEEZE)
];
indices(cm_definitions, _CM);
! dec_name, declaration names for input and output;
! don't juggle the order of these definitions, because the parse will cease to
function;
define dec_name_definitions=[
xx(SCALAR, SVAR)
xx(VECTOR, VVAR)
xx(ROT, RVAR)
xx(FRAME, FVAR)
xx(PLANE, PVAR)
xx(TRANS, TVAR)
xx(EVENT, EVAR)
xx(ATOM, ATOM)
xx(WORLD, WVAR)
xx(CM_LABEL, ONLAB)
xx(CLC_LABEL, CLCLAB)
xx(CH_LABEL, CHGLAB)
xx(LABEL, LABEL)
];
! data types;
DEFINE
form_VALUE =-1,
boole_VALUE =0; ! others follow directly;
define
dec_name_count=0;
redefine xx(in, out)=[
redefine dec_name_count=dec_name_count+1;
redefine xx_temp="define in" & "_VALUE=" & cvms(dec_name_count);
xx_temp;];
dec_name_definitions;
define frame_exp_VALUE=trans_VALUE; ! COERCION DICTATES THAT THESE BE THE SAME;
redefine xx(in, out)=["out",];
preload_array(
dec_name, dec_name_definitions, string, 1, dec_name_count);
! operators;
! ********** WARNING!!!!! **********
keep all entries marked TRUE contiguous
don't disturb the order of this table ;
define operator_definitions=[
XX(NOT, 1, FALSE, boole, boole, ignore)
XX(AND, 2, FALSE, boole, boole, ignore)
XX(OR, 2, FALSE, boole, boole, ignore)
XX(SEQ, 2, FALSE, boole, scalar, ignore)
XX(SNE, 2, FALSE, boole, scalar, ignore)
XX(SGT, 2, FALSE, boole, scalar, ignore)
XX(SLT, 2, FALSE, boole, scalar, ignore)
XX(SGE, 2, FALSE, boole, scalar, ignore)
XX(SLE, 2, FALSE, boole, scalar, ignore)
XX(UVECT, 1, FALSE, vector, vector, same)
XX(AXIS, 1, FALSE, vector, rot, ignore)
XX(POS, 1, FALSE, vector, trans, ignore)
XX(ORIENT, 1, FALSE, rot, trans, ignore)
XX(TMAKE, 2, TRUE, trans, boole, ignore)
XX(VMAKE, 3, TRUE, vector, scalar, ignore)
XX(FMAKE, 2, TRUE, trans, boole, ignore)
XX(VVTRANS, 3, TRUE, trans, scalar, ignore)
XX(SNEG, 1, TRUE, scalar, scalar, same)
XX(RINV, 1, TRUE, scalar, scalar, inverse)
XX(SABS, 1, TRUE, scalar, scalar, same)
XX([+], 2, TRUE, scalar, scalar, check, PLUS)
XX([-], 2, TRUE, scalar, scalar, check, MINUS)
XX([*], 2, TRUE, scalar, scalar, multiply, TIMES)
XX(WRT, 2, TRUE, scalar, scalar, multiply)
XX(ROT, 2, TRUE, vector, boole, ignore)
XX(→, 2, TRUE, trans, boole, divide)
XX(VDOT, 2, FALSE, scalar, vector, multiply)
XX(ANGLE, 2, FALSE, scalar, vector, ignore)
XX(VCROSS, 2, FALSE, vector, vector, multiply)
XX(VVROT, 2, FALSE, rot, vector, ignore)
XX(SDIV, 2, FALSE, scalar, scalar, divide)
XX(STOS, 2, FALSE, scalar, scalar, ignore)
XX(NOMV, 1, FALSE, form, form, same)
];
define
first_true_op=-1,
op_count=0;
redefine xx(str1, i1, boole, i2, i3, i4, str2)=[
redefine op_count=op_count+1;
ifc "str2"=null
thenc redefine xxtemp=[define str1] & "_X=op_count";
elsec redefine xxtemp=[define str2] & "_X=op_count";
endc
xxtemp;
ifc first_true_op<0 and boole
thenc redefine first_true_op=op_count; endc];
operator_definitions;
define zap_op(name, type, arg, postfix)=[
ifc "postfix"=null
thenc redefine xx(str1, i1, boole, i2, i3, i4, str2)=[arg,];
elsec redefine xx(str1, i1, boole, i2, i3, i4, str2)=
[arg]&[postfix,];
endc
preload_array(name, operator_definitions, type, 1, op_count)];
zap_op(
op_array, string, "str1");
zap_op(
op_num, integer, i1);
zap_op(
op_bool, boolean, boole);
zap_op(
result_type, integer, i2, _VALUE);
zap_op(
type_of_args, integer, i3, _VALUE);
! specifies how to work out new DIMENSION of argument ;
define
ignore_dimen =0,
same_dimen =1,
inverse_dimen =2,
check_dimen =3,
multiply_dimen =4,
divide_dimen =5;
zap_op(
dimen_changes, integer, i4, _dimen);
! reserved_words;
define reserved_definitions=[
xx([}], brace)
xx([{], brace)
xx(FORCE, cm, force_cm)
xx(TORQUE, cm, torque_cm)
xx(FORCE_OR_TORQUE, cm, force_or_torque_cm)
xx(DURATION, cm)
xx(TEMPERATURE, cm)
xx(SQUEEZE, cm)
xx(BEGIN)
xx(COBEGIN)
xx(END)
xx(COEND, end)
xx([;], end)
xx([(], open_paren)
xx(SCALAR, declare, scalar_value)
xx(VECTOR, declare, vector_value)
xx(ROT, declare, rot_value)
xx(FRAME, declare, frame_value)
xx(PLANE, declare, plane_value)
xx(TRANS, declare, trans_value)
xx(EVENT, declare, event_value)
xx(ATOM, declare, atom_value)
xx(WORLD, declare, world_value)
xx(CM_LABEL, declare, cm_label_value)
xx(CLC_LABEL, declare, clc_label_value)
xx(CH_LABEL, declare, ch_label_value)
xx(LABEL, declare, label_value)
xx(GLOBAL)
xx(IF)
xx(PLAN)
xx(WHILE)
xx(FOR)
xx(MOVE)
xx(AFFIX)
xx(UNFIX)
xx(SIGNAL)
xx(WAIT)
xx(WHEN)
xx(DUMP)
xx(ASSERT)
xx(DENY, assert)
xx(ON)
xx(REFERENCE)
xx(PARSESHIT)
xx(OPEN)
xx(CLOSE, open)
xx(CENTER)
xx(STOP)
xx(DEFINE)
xx(REQUIRE)
xx(DIMENSION)
xx(COMMENT, dimension)
xx(ABORT)
xx(PRINT, abort)
xx(PAUSE, abort)
xx([,], comma)
xx(OR, or, or_X)
xx(AND, and, and_X)
xx(NOT, not, not_X)
xx([∨], or, or_X)
xx([∧], and, and_X)
xx([¬], not, not_X)
xx([=], order, seq_X)
xx([≠], order, sne_X)
xx([>], order, sgt_X)
xx([<], order, slt_X)
xx([≥], order, sge_X)
xx([≤], order, sle_X)
xx([|], abs)
xx(VVVTRANS, abs)
xx([+], add, plus_X)
xx([-], add, minus_X)
xx([.], mult, vdot_X)
xx([*], mult, times_X)
xx([/], mult, sdiv_X)
xx([⊗], mult, vcross_X)
xx(WRT, mult, wrt_X)
xx(VVROT, mult, vvrot_X)
xx(→, trans, →_X)
xx([↑], trans, stos_X)
xx([#], vector, nomv_X)
xx(ORIENT, vector, orient_X)
xx(UNIT, vector, uvect_X)
xx(AXIS, vector, axis_X)
xx(POS, vector, pos_X)
xx(INV, vector, rinv_X)
xx([)], close_paren)
xx(VIA)
xx(WITH)
xx(SOURCE_FILE)
xx(DELIMITERS)
xx(UNSTACK_DELIMITERS)
xx(REPLACE_DELIMITERS)
xx(DISTANCE, metric, distance_METRIC)
xx(TIME, metric, time_METRIC)
xx(MASS, metric, mass_METRIC)
xx(ANGLE, metric, angle_METRIC)
xx(ARRIVAL)
xx(DEPARTURE, arrival)
xx([?], misc)
xx(ABS, misc)
xx(TO, misc)
xx(TRACING, misc)
xx(WHERE, misc)
xx(THEN, misc)
xx(ENABLE, misc)
xx(DISABLE, misc)
xx(DO, misc)
xx(FORM, misc)
xx(AT, misc)
xx(BY, misc)
xx(CHANGING, misc)
xx(ALSO, misc)
xx(DONT, misc)
xx(ONLY, misc)
xx(RIGIDLY, misc)
xx(NONRIGIDLY, misc)
xx(STEP, misc)
xx(UNTIL, misc)
xx(ELSE, misc)
];
define
reserved_count=0;
redefine xx(name, class, special)=[
redefine reserved_count=reserved_count+1;];
reserved_definitions;
redefine xx(name, class, special)=["name",];
preload_array(
reserved_words, reserved_definitions, string, 1, reserved_count);
redefine xx(name, class, special)=[
ifc "class"=null
thenc redefine xxtemp=[name] & "_RES";
elsec redefine xxtemp=[class] & "_RES";
endc
xxtemp,];
preload_array(
reserved_class, reserved_definitions, integer, 1, reserved_count);
redefine xx(name, class, special)=[
ifc "special"=null thenc 0 elsec special endc,];
preload_array(
reserved_special, reserved_definitions, integer, 1, reserved_count);
string array
reserved[0:hasher-1];
integer array
com_type[0:hasher-1];
! init_reserved;
forward INTEGER PROCEDURE HASH(STRING S;INTEGER MAX);
procedure init_reserved;
α string s; integer i, k;
boolean procedure find_sym(string s; reference integer k);
α string probe;
k ← hash(s, hasher);
while (probe ← reserved[k])≠null do
if equ(s, probe) then return(true) else k ← (k+1) mod hasher;
return(false);
β;
arrclr(reserved); arrclr(com_type);
for i ← 1 step 1 until reserved_count do
if find_sym(reserved_words[i], k)
then outstr(reserved_words[i] & " doubly defined!" & crlf)
else
α
reserved[k] ← reserved_words[i];
com_type[k] ← reserved_class[i]+reserved_special[i]*hasher;
β;
β;
require init_reserved initialization [0];
! predefined constants;
define constant_definitions=[
XX(GARB_ID, scalar, nil) ! do not move this entry;
XX(PI, scalar, nil)
XX(CM, scalar, distance)
XX(SEC, scalar, time)
XX(GM, scalar, mass)
XX(DEG, scalar, angle)
XX(XHAT, vector, distance)
XX(YHAT, vector, distance)
XX(ZHAT, vector, distance)
XX(NILVECT, vector, distance)
XX(NILROTN, rot, angle)
XX(NILTRANS, trans, distance)
XX(STATION, trans, distance)
XX(YPARK, trans, distance)
XX(BPARK, trans, distance)
XX(BLUE, trans, distance)
XX(YELLOW, trans, distance)
XX(BHAND, scalar, distance)
XX(BARM, trans, distance)
XX(YHAND, scalar, distance)
XX(YARM, trans, distance)
XX(TRUE, boole, nil)
XX(FALSE, boole, nil)
];
define
const_count = 0;
redefine xx(str, i1, i2)=[redefine const_count = const_count+1;];
constant_definitions;
define zap_const(name, type, arg, postfix)=[
ifc "postfix"=null
thenc redefine xx(str, i1, i2)=[arg,];
elsec redefine xx(str, i1, i2)=[arg] & [postfix,];
endc
preload_array(name, constant_definitions, type, 1, const_count)];
zap_const(
preconst, string, "str");
zap_const(
preconst_type, integer, i1, _VALUE);
zap_const(
pre_dimens, integer, i2, _METRIC);
! compiler switches and control tables;
! As the AL compile time system runs, several intermediate files are created
and destroyed. The default extensions of these files are listed below.
.AL user the ALGOL like AL source language
.SEX AL s-expression version of AL source code
.ALP (.AL0) ALC pseudo code
.ALT (.AL1) ALC trajectory file
.ALV (.AL2) ALC constants and variable definitions for pseudo code
.ALS (.AL3) ALC symbol table usable by the PDP-11 runtime system
.ALL ALC hybrid s-expression/real AL listing
.LST PALX PDP-11 assembly code listing
.BIN PALX PDP-11 binary file loaded by 11TTY
.DMP 11TTY PDP-11 core image
;
! compiler switches;
define compiler_switches=[
xx(K, false) ! keep extraneous intermediate files: .ALP, .ALV, .ALT;
xx(S, false) ! inhibit the deletion of the .SEX file;
xx(L, false) ! generate a PALX assembly listing;
xx(B, false) ! run BAIL immediately after scanning the command line;
xx(E, false) ! load the .BIN file into the PDP-11;
];
indices(compiler_switches, _X);
define
switch_max =xxcount-1;
redefine xx(name, default)=["name",]; preload_array(
switch_name, compiler_switches, string, 0, switch_max+1);
redefine xx(name, default)=[default,]; preload_array(
switch_default, compiler_switches, boolean, 0, switch_max+1);
boolean array
switch_setting[0:switch_max];
procedure preset_switches;
α integer i;
for i ← 0 step 1 until switch_max do switch_setting[i] ← switch_default[i];
β;
require preset_switches initialization[0];
! hash, declaration of debugging variables, start of hidden_parse;
INTEGER PROCEDURE HASH(STRING S;INTEGER MAX);
α INTEGER I,TOT,C;
C←I←1; TOT←0;
WHILE I≠0 DO TOT←TOT+(C←C+1)*(I←LOP(S));
RETURN(TOT MOD MAX);
β;
ifc debug_compile thenc ! some variables that can be used for debugging;
require "BREAK.HDR[1,PJ]" source_file;
record_pointer(any_class)
__r0, __r1, __r2, __r3, __r4, __r5, __r6, __r7, __r8, __r9;
string
__s0, __s1, __s2, __s3, __s4, __s5, __s6, __s7, __s8, __s9;
integer
__i0, __i1, __i2, __i3, __i4, __i5, __i6, __i7, __i8, __i9;
real
__x0, __x1, __x2, __x3, __x4, __x5, __x6, __x7, __x8, __x9;
procedure debug_init;
α
__r0 ← __r1 ← __r2 ← __r3 ← __r4 ← __r5 ← __r6 ← __r7 ← __r8 ← __r9 ← null_record;
__s0 ← __s1 ← __s2 ← __s3 ← __s4 ← __s5 ← __s6 ← __s7 ← __s8 ← __s9 ← null;
__i0 ← __i1 ← __i2 ← __i3 ← __i4 ← __i5 ← __i6 ← __i7 ← __i8 ← __i9 ← 0;
__x0 ← __x1 ← __x2 ← __x3 ← __x4 ← __x5 ← __x6 ← __x7 ← __x8 ← __x9 ← 0.0;
β;
require debug_init initialization[0];
endc
! The following (making all of parse a recursive procedure) is a hack to get the
restart option to work properly. As soon as a better way is found of
making sure everything gets reinitialized properly, this should be taken
out;
recursive procedure hidden_parse;
α "hidden_parse"
! ---- DECLARATIONS ----;
external integer
rpgsw;
record_pointer(file)
AL_file, ! AL source file;
SEX_file, ! s-expression file;
BIN_file, ! PALX binary file;
ALL_file; ! ALC listing file;
BOOLEAN
DISK, ! TRUE IF INPUT IS COMING FROM DISK;
AUTO_PROCEED; ! TRUE IF AUTO_PROCEED SWITCH IS ON FOR ERROR RECOVERY;
STRING
cmd_line,
INFILE,
OUTFILE; ! INPUT&OUTPUT FILES;
INTEGER
CHANIN,
CHANOUT;
STRING
INSTRING, ! INPUT STRING;
TABLE1; ! BREAK TABLES;
INTEGER
TYPE_OF_TOKEN;
define
special_token =0,
id_token =1,
numeric_token =2,
string_token =3;
integer
TYPE_OF_RES_WORD, ! TYPE PULLED OFF OF COM_TYPE;
SPECIAL_INFO, ! INFO PASSED FROM SCANNER TO PARSER - DEPENDS ON TYPE;
word_R_break, ! break tables;
non_blank_break,
word_S_break,
close_brace_break,
non_digit_break,
quote_break,
macro_delimiter_break,
semicolon_A_break,
cr_break,
paren_cr_break,
lf_ff_break,
semicolon_R_break,
omit_break;
STRING
TOKEN,
CURRENT_FRAME; ! TOKEN OF THE CURRENT FRAME - DEFAULT SET TO "YARM";
INTEGER
SPACING; ! SPACING FOR OUTPUT;
BOOLEAN
REJECT; ! TRUE WHEN THE LAST TOKEN IS REJECTED BY THE CALLING PROC;
INTEGER
DEC_NUM; ! THE NUMBER OF DECLARATIONS IN THE CURRENT BLOCK;
STRING
OUTEXPR; ! FOR THE CONSTRUCTION OF THE STRING FOR EXPRESSIONS;
RECORD_CLASS
PARAM_LIST(
STRING
ID;
RECORD_POINTER(PARAM_LIST)
NEXT
);
RECORD_CLASS
MACRO_LIST(
STRING
VALUE, ! ACTUAL MACRO body;
ID;
INTEGER
NUM; ! NUMBER OF PARAMETERS;
RECORD_POINTER(MACRO_LIST)
NEXT, ! POINTS TO NEXT MACRO WHICH HASHES TO THE SAME ENTRY;
LAST, ! BACK POINTER IN THE SAME LIST;
LINK; ! USED ONLY FOR PARAMETER EXPANSION, POINTS TO THE
PARAMETER DEFINED JUST BEFORE THIS ONE;
RECORD_POINTER(PARAM_LIST)
PARAMS
);
RECORD_POINTER(MACRO_LIST)
TOP_PARAM;
RECORD_POINTER(MACRO_LIST) ARRAY
MACRO_TABLE[0:hasher];
RECORD_CLASS
DELIMITER_LIST(
STRING
D1,
D2;
RECORD_POINTER(DELIMITER_LIST)
NEXT
);
RECORD_POINTER(DELIMITER_LIST)
TOP_DELIMITERS;
RECORD_CLASS
SOURCE_LIST(
INTEGER
CHAN, ! i/o CHANNEL NUMBER OF input, -1 if from macro;
NUM; ! NUMBER OF PARAMETERS IN THE CURRENT MACRO;
STRING
CUR_STRING, ! curline WHEN PUSHED;
CUR_STRINGR, ! curliner WHEN PUSHED;
FILE_NAME; ! NAME OF THE INPUT FILE WHEN PUSHED;
RECORD_POINTER(SOURCE_LIST)
NEXT;
INTEGER
PN,
LN ! PAGE AND LINE NUMBER OF THE PUSHED FILE;
);
RECORD_POINTER(SOURCE_LIST)
TOP_SOURCE;
RECORD_CLASS
DIMENS_LIST(
INTEGER
VALUE;
RECORD_POINTER(DIMENS_LIST)
NEXT
);
RECORD_POINTER(DIMENS_LIST)
UPPER_D,
LOWER_D;
RECORD_CLASS
ID_LIST(
STRING
NAME;
INTEGER
TYPE;
RECORD_POINTER(ID_LIST)
NEXT, ! POINTS TO NEXT ID WHICH HASHES TO THE SAME ENTRY;
LINK; ! POINTS TO THE ID DEFINED JUST BEFORE THIS ONE;
BOOLEAN
LABEL_USED;
INTEGER
DIMEN_P,
BLOCK_LEVEL_OF_DEFN
);
RECORD_POINTER(ID_LIST) ARRAY
SYMBOL_TABLE[0:hasher];
RECORD_POINTER(ID_LIST)
TOP_ID;
RECORD_POINTER(DIMENS_LIST)
DISTANCE_DIMENS; ! WILL HOLD DIMENS LIST FOR DISTANCE -- NEEDED FOR ⊗;
INTEGER
EXP_TYPE; ! TYPE OF EXPRESSION FOUND BY P_EXP;
BOOLEAN
PLAN_STATEMENT; ! TRUE IF CURRENT STATMENT IS PREFIXED BY PLAN;
STRING
CHANGER_HEAD; ! NON NULL IF PARSING A STATEMENT INSDIDE A CHANGER;
INTEGER
T_COUNT; ! COUNTER FOR PRODUCING UNIQUE ID'S;
RECORD_POINTER(DIMENS_LIST)
EXP_UP_D,
EXP_LOW_D;
RECORD_CLASS
EXPR(
INTEGER
TYPE;
STRING
OP,
ID;
RECORD_POINTER(DIMENS_LIST)
UPPER_DIMEN,
LOWER_DIMEN;
RECORD_POINTER(ANY_CLASS)
PARTS
);
RECORD_CLASS
EXPR_LIST(
RECORD_POINTER(EXPR)
EXP;
RECORD_POINTER(EXPR_LIST)
NEXT
);
RECORD_CLASS
OP_LIST(
RECORD_POINTER(OP_LIST)
NEXT;
INTEGER
PRIORITY,
OP,
NUM_OF_ARGS,
COUNT;
BOOLEAN
ARG_DEP,
FUNC
);
BOOLEAN
OP_EXPECTED; ! TRUE WHEN P_EXP EXPECTS AN OPERATION;
RECORD_POINTER(OP_LIST)
OPS,
OPSAVE;
RECORD_POINTER(EXPR_LIST)
EXPRS,
EXPRSAVE;
RECORD_POINTER(EXPR)
EXP1,
EXP2,
EXP3;
INTEGER
DELIMITER_1, ! non-zero only while defining macro;
DELIMITER_2; ! HEAD AND TAIL DELIMITER OF macro bodies;
INTEGER
MAC_NUM; ! NUMBER OF PARAMS IN THE CURRENT MACRO EXPANSION;
RECORD_POINTER(DIMENS_LIST) ARRAY
DIMEN_DEFS,
DIMEN_DEFS2[0:16];
INTEGER
DIMEN_NUM,
BLOCK_LEVEL;
! GARBAGE DECLARATIONS (VERY LOCAL);
BOOLEAN
T,
EOF;
INTEGER
COUNT,
I,
N,
BRCHAR;
STRING
GARB;
INTEGER
LINENUM,
PAGENUM,
SOSNUM,
typed_page_num, ! on tty;
sourcelvl;
STRING
CURLINER,
CURLINE;
! error, error_reject, print, file_indent;
FORWARD RECURSIVE PROCEDURE P_STATEMENT;
FORWARD RECURSIVE PROCEDURE GET_TOKEN;
string procedure source_pos;
return("File "& INFILE& ", Page "& CVS(PAGENUM+1)& ", Line "& CVS(LINENUM));
PROCEDURE ERROR(INTEGER I;STRING S);
! RIGHT NOW THIS PROCEDURE IS KIND OF DUMB. IT'S INCLUDED IN THE HOPE
OF EVENTUALLY MAKING THE ERROR FACILITY MORE VERSATILE;
! I don't understand the error number stuff. All errors numbered 200
have been added by me and can be arbitrarily reassigned.
PJ 8/30/76;
α INTEGER L1,L2; BOOLEAN PROCEED; INTEGER COMMAND_CHAR;
WHILE EQU(CURLINE[1 TO 1], lf) DO GARB←LOP(CURLINE);
L1←LENGTH(CURLINER); L2←LENGTH(CURLINE)-L1; PROCEED←AUTO_PROCEED;
OUTSTR(crlf & "YOU LOOSE - ERROR TYPE " & CVS(I) & crlf & S & crlf
& source_pos & crlf & CURLINE[1 TO L2] & lf & CURLINER & crlf);
WHILE ¬PROCEED DO
α
CLRBUF; OUTSTR("↑"); COMMAND_CHAR←INCHRW;
IF COMMAND_CHAR="B" THEN
α
OUTSTR("ail" & crlf);
IFC debug_compile
THENC BAIL
ELSEC OUTSTR("Sorry, Bail not loaded." & crlf)
ENDC;
β
ELSE IF COMMAND_CHAR=cr THEN
α CLRBUF; PROCEED←TRUE; β
ELSE IF COMMAND_CHAR=lf THEN
α PROCEED←TRUE; AUTO_PROCEED←TRUE; β
ELSE IF COMMAND_CHAR="E" THEN
α OUTSTR("dit" & crlf); EDFILE(INFILE,LINENUM,PAGENUM+1,0); β
ELSE IF COMMAND_CHAR="R" THEN
α
OUTSTR("estart"); CURLINE←CURLINER←null;
USERERR(0,1,NULL,"S"); ! THIS IS A HACK AND SHOULD BE CHANGED
AS SOON AS POSSIBLE;
β
ELSE IF COMMAND_CHAR="X" THEN
α OUTSTR("it" & crlf);
USERERR(0,1,NULL,"X"); ! DITTO ABOVE COMMENT;
β
ELSE OUTSTR("Reply [CR] to continue," & crlf &
"[LF] to continue automatically," & crlf &
"""B"" to load Bail," & crlf &
"""E"" to edit source file," & crlf &
"""R"" to restart," & crlf &
"""X"" to exit." & crlf);
β;
β;
PROCEDURE ERROR_REJECT(INTEGER I;STRING S);
α ERROR(I,S); REJECT←TRUE; β;
PROCEDURE PRINT(STRING S);
α
ifc debug_compile thenc
INTEGER I,J,K,L;
FOR I←1 STEP 1 UNTIL SPACING DO S←" "&S;
J←LENGTH(S);
WHILE J>80 DO
α;
K←80;
WHILE K≤J AND ¬EQU(S[K TO K]," ") DO K←K+1;
OUT(CHANOUT,S[1 TO K] & crlf);
S←S[K+1 TO J];
J←J-K;
β;
OUT(CHANOUT,S & crlf)
elsec
INTEGER I;
FOR I←1 STEP 1 UNTIL SPACING DO OUT(CHANOUT," ");
OUT(CHANOUT,S & crlf);
endc;
β;
procedure file_indent(integer i);
α
typed_page_num ← false;
outstr(" "[1 for 2*i]);
β;
! read, push_macro_delimiters;
STRING PROCEDURE READ(INTEGER BTABLE);
! RIGHT NOW THIS PROCEDURE IS KIND OF DUMB. IT'S INCLUDED IN THE HOPE
OF EVENTUALLY MAKING THE READING FACILITY MORE VERSATILE;
α STRING TEXT;
text ← SCAN(CURLINER,BTABLE,BRCHAR);
WHILE BRCHAR=0 DO
α BOOLEAN REPLACED;
REPLACED←TRUE;
IF CHANIN≠-1 THEN CURLINE←CURLINER←INPUT(CHANIN,lf_ff_break);
IF CHANIN=-1 THEN
α "pop macro"
FOR I←1 STEP 1 UNTIL SOURCE_LIST:NUM[TOP_SOURCE] DO
α
IF REPLACED AND EQU(TEXT,MACRO_LIST:ID[TOP_PARAM]) THEN
α
TEXT←MACRO_LIST:VALUE[TOP_PARAM];
REPLACED←FALSE;
SOURCE_LIST:CUR_STRINGR[TOP_SOURCE]←" "&
SOURCE_LIST:CUR_STRINGR[TOP_SOURCE];
β;
IF MACRO_LIST:LAST[TOP_PARAM]=NULL THEN
MACRO_TABLE[HASH(MACRO_LIST:ID[TOP_PARAM],hasher)]
← MACRO_LIST:NEXT[TOP_PARAM]
ELSE IF MACRO_LIST:NEXT[TOP_PARAM]=NULL THEN
MACRO_LIST:LAST[TOP_PARAM]
← MACRO_LIST:NEXT[TOP_PARAM]
ELSE α
MACRO_LIST:LAST[TOP_PARAM]
← MACRO_LIST:NEXT[TOP_PARAM];
MACRO_LIST:NEXT[TOP_PARAM]
← MACRO_LIST:LAST[TOP_PARAM];
β;
β;
CHANIN←SOURCE_LIST:CHAN[TOP_SOURCE];
CURLINE←SOURCE_LIST:CUR_STRING[TOP_SOURCE];
CURLINER←" "&SOURCE_LIST:CUR_STRINGR[TOP_SOURCE];
PAGENUM←SOURCE_LIST:PN[TOP_SOURCE];
LINENUM←SOURCE_LIST:LN[TOP_SOURCE];
TOP_SOURCE←SOURCE_LIST:NEXT[TOP_SOURCE];
β "pop macro"
ELSE IF BRCHAR=lf THEN LINENUM←LINENUM+1
ELSE IF BRCHAR=ff THEN
α
outstr(" " & cvs((PAGENUM←PAGENUM+1)+1));
typed_page_num ← true; LINENUM←0
β
ELSE IF TOP_SOURCE≠NULL THEN
α "close_source"
RELEASE(CHANIN);
PAGENUM←SOURCE_LIST:PN[TOP_SOURCE];
LINENUM←SOURCE_LIST:LN[TOP_SOURCE];
CURLINE←SOURCE_LIST:CUR_STRING[TOP_SOURCE];
CURLINER←SOURCE_LIST:CUR_STRINGR[TOP_SOURCE];
CHANIN←SOURCE_LIST:CHAN[TOP_SOURCE];
INFILE←SOURCE_LIST:FILE_NAME[TOP_SOURCE];
MAC_NUM←SOURCE_LIST:NUM[TOP_SOURCE];
TOP_SOURCE←SOURCE_LIST:NEXT[TOP_SOURCE];
outstr(crlf); typed_page_num ← false; sourcelvl ← sourcelvl-1;
β "close_source"
ELSE IF EOF THEN ERROR(500,"end of file encountered unexpectedly.");
TEXT ← TEXT & SCAN(CURLINER,BTABLE,BRCHAR);
β;
RETURN(TEXT);
β;
procedure push_delimiters(string s);
α record_pointer(delimiter_list) new_del;
DELIMITER_LIST:NEXT[NEW_DEL ← new_record(delimiter_list)] ← TOP_DELIMITERS;
DELIMITER_LIST:D1[NEW_DEL] ← lop(s); DELIMITER_LIST:D2[NEW_DEL] ← lop(s);
TOP_DELIMITERS←NEW_DEL;
β;
! mac_test_and_expand;
! TEST TO SEE IF A GIVEN TOKEN IN THE NAME OF A MACRO AND IF IT IS, EXPAND IT;
RECURSIVE PROCEDURE MAC_TEST_AND_EXPAND;
α INTEGER HASH_ENTRY; RECORD_POINTER (MACRO_LIST) MAC_POINT2;
HASH_ENTRY←HASH(TOKEN,hasher); MAC_POINT2←MACRO_TABLE[HASH_ENTRY];
WHILE MAC_POINT2≠NULL AND ¬EQU(MACRO_LIST:ID[MAC_POINT2],TOKEN) DO
MAC_POINT2←MACRO_LIST:NEXT[MAC_POINT2];
IF MAC_POINT2=NULL
THEN TYPE_OF_TOKEN←id_token
ELSE
α "expand macro"
STRING MAC_ID; RECORD_POINTER(PARAM_LIST) PARAMS;
RECORD_POINTER(SOURCE_LIST)NEW_SOURCE2;
PARAMS←MACRO_LIST:PARAMS[MAC_POINT2]; MAC_ID←TOKEN; GET_TOKEN;
IF ¬EQU(TOKEN,"(") AND PARAMS≠NULL
THEN ERROR(59,"Parametered macro used without params.")
ELSE IF ¬EQU(TOKEN,"(")
THEN CURLINER←TOKEN&CURLINER
ELSE
α "macro parameters" STRING VALUE, NAME;
FOR I←1 STEP 1 UNTIL MACRO_LIST:NUM[MAC_POINT2] DO
α RECORD_POINTER(MACRO_LIST)SUB_MACRO;
NAME←PARAM_LIST:ID[PARAMS]; PARAMS←PARAM_LIST:NEXT[PARAMS];
IF EQU(TOKEN,")") THEN
ERROR(60,"Number of parameters disagree with definition.");
GET_TOKEN;
IF TYPE_OF_TOKEN≠string_token THEN
ERROR(61,"Need a string here.");
VALUE←TOKEN;
GET_TOKEN;
IF ¬EQU(TOKEN,",") AND ¬EQU(TOKEN,")") THEN
ERROR_REJECT(62,"Need either comma or right paren here.");
SUB_MACRO←NEW_RECORD(MACRO_LIST);
MACRO_LIST:VALUE[SUB_MACRO]←VALUE;
MACRO_LIST:ID[SUB_MACRO]←NAME;
MACRO_LIST:NUM[SUB_MACRO]←0;
MACRO_LIST:LINK[SUB_MACRO]←TOP_PARAM;
TOP_PARAM←SUB_MACRO;
HASH_ENTRY←HASH(NAME,hasher);
MACRO_LIST:NEXT[SUB_MACRO]←MACRO_TABLE[HASH_ENTRY];
IF MACRO_TABLE[HASH_ENTRY]≠NULL
THEN MACRO_LIST:LAST[MACRO_TABLE[HASH_ENTRY]] ← MAC_POINT2;
MACRO_TABLE[HASH_ENTRY]←SUB_MACRO;
β;
IF ¬EQU(TOKEN,")") THEN ERROR(62,"Number of parameters don't match the defn.");
β "macro parameters";
NEW_SOURCE2←NEW_RECORD(SOURCE_LIST);
SOURCE_LIST:CHAN[NEW_SOURCE2]←CHANIN;
SOURCE_LIST:NUM[NEW_SOURCE2]←MACRO_LIST:NUM[MAC_POINT2];
SOURCE_LIST:NEXT[NEW_SOURCE2]←TOP_SOURCE;
SOURCE_LIST:CUR_STRING[NEW_SOURCE2]←CURLINE;
SOURCE_LIST:CUR_STRINGR[NEW_SOURCE2]←CURLINER;
SOURCE_LIST:PN[NEW_SOURCE2]←PAGENUM;
SOURCE_LIST:LN[NEW_SOURCE2]←LINENUM;
CHANIN←-1;
CURLINE←CURLINER←MACRO_LIST:VALUE[MAC_POINT2];
TOP_SOURCE←NEW_SOURCE2;
GET_TOKEN;
β "expand macro";
β;
! get_token;
! THIS PROCEDURE GETS THE NEXT TOKEN. PUTS THE TOKEN IN "TOKEN" THE TYPE OF
THE TOKEN IN "TYPE_OF_TOKEN";
RECURSIVE PROCEDURE GET_TOKEN;
α "get_token" BOOLEAN T; INTEGER POINT;
IF REJECT THEN α REJECT←FALSE; RETURN; β;
TYPE_OF_TOKEN←special_token; T←TRUE;
WHILE T DO
α "while_T"
READ(non_blank_break); TOKEN←READ(word_R_break);
IF EQU(TOKEN,NULL) THEN
α "isolated break"
IF BRCHAR="."
THEN
α REAL NUM;
CURLINER←"0"&CURLINER;
if (NUM←REALSCAN(CURLINER,BRCHAR))≠0
THEN
α
TYPE_OF_TOKEN←numeric_token; TOKEN←CVG(NUM)
β
ELSE TOKEN←".";
β
ELSE IF BRCHAR="-" THEN
α REAL NUM;
garb ← LOP(CURLINER); CURLINER←"-0"&CURLINER;
if (NUM←REALSCAN(CURLINER,BRCHAR))≠0
THEN
α
TYPE_OF_TOKEN←numeric_token; TOKEN←CVG(NUM)
β
ELSE TOKEN←"-";
β;
IF EQU(TOKEN,NULL) THEN α READ(word_S_break); TOKEN←BRCHAR; β;
β "isolated break";
IF EQU(TOKEN,"{") THEN TOKEN←READ(close_brace_break) ELSE T←FALSE;
β "while_T";
IF TOKEN=dquote THEN
α "found_string"
TOKEN←READ(quote_break); TYPE_OF_TOKEN←string_token;
while curliner=dquote do token ← token & lop(curliner) & read(quote_break);
RETURN;
β "found_string";
! delimiter_1 non-zero only while defining macro;
if delimiter_1 and token=delimiter_1 then
α "found_macro_body" integer lvl;
token←read(macro_delimiter_break); type_of_token ← string_token;
if delimiter_1=delimiter_2 ∨ brchar=delimiter_2 then return;
lvl ← 2; if brchar≠delimiter_1 then error(200, "macro body scan lost");
do α
token ← token & brchar & read(macro_delimiter_break);
if brchar=delimiter_2
then lvl ← lvl-1
else if brchar=delimiter_1
then lvl ← lvl+1
else error(200, "macro body scan lost");
β
until lvl ≤ 0;
return;
β "found_macro_body";
! look for reserved word;
IF TYPE_OF_TOKEN=special_token THEN
α
POINT←HASH(TOKEN,hasher);
WHILE ¬EQU(RESERVED[POINT],NULL) AND ¬EQU(RESERVED[POINT],TOKEN) DO
POINT←(POINT+1)MOD hasher;
IF RESERVED[POINT]=TOKEN
THEN
α "reserved word" INTEGER VAL;
TYPE_OF_TOKEN←special_token;
VAL←COM_TYPE[POINT];
IF VAL≥hasher
THEN
α
SPECIAL_INFO←(VAL DIV hasher);
TYPE_OF_RES_WORD←(VAL MOD hasher);
β
ELSE α SPECIAL_INFO←0; TYPE_OF_RES_WORD←VAL; β;
β "reserved word"
ELSE
α "not reserved"
IF ¬("0" ≤ token ≤ "9")
THEN MAC_TEST_AND_EXPAND
ELSE
α "numeric" REAL NUM1,NUM2; INTEGER NUMGARB;
TYPE_OF_TOKEN←numeric_token;
NUM1←INTSCAN(TOKEN,NUMGARB);
IF ¬EQU(TOKEN,NULL) THEN ERROR(0,"Illegal token." &
crlf & "Garbage after digits will be ignored.");
IF BRCHAR="."
THEN
α
CURLINER←"0"&CURLINER;
NUM2←REALSCAN(CURLINER,BRCHAR);
TOKEN←CVG(NUM1+NUM2);
β
ELSE IF BRCHAR="@"
THEN
α
CURLINER←"1"&CURLINER;
NUM2←REALSCAN(CURLINER,BRCHAR);
TOKEN←CVG(NUM1*NUM2);
β
ELSE TOKEN←CVG(NUM1);
β "numeric";
β "not reserved";
β;
β "get_token";
! check;
PROCEDURE CHECK(STRING S; REFERENCE RECORD_POINTER(DIMENS_LIST) D1,D2,D3,D4);
α RECORD_POINTER(DIMENS_LIST) II1,II2,II3,II4;
II1←D1; II2←D2; II3←D3; II4←D4;
WHILE II1≠NULL_RECORD AND II3≠NULL_RECORD DO
α
IF DIMENS_LIST:VALUE[II1]≠DIMENS_LIST:VALUE[II3] THEN
ERROR(122,"Dimensions don't match on "&S&".");
II1←DIMENS_LIST:NEXT[II1]; II3←DIMENS_LIST:NEXT[II3];
β;
IF II1≠NULL_RECORD OR II3≠NULL_RECORD THEN
ERROR(122,"Dimensions don't match on "&S&".");
WHILE II2≠NULL_RECORD AND II4≠NULL_RECORD DO
α
IF DIMENS_LIST:VALUE[II2]≠DIMENS_LIST:VALUE[II4] THEN
ERROR(122,"Dimensions don't match on "&S&".");
II2←DIMENS_LIST:NEXT[II2]; II4←DIMENS_LIST:NEXT[II4];
β;
IF II2≠NULL_RECORD OR II4≠NULL_RECORD THEN
ERROR(122,"Dimensions don't match on "&S&".");
β;
! combine
calling sequence:
combine(expr:UPPER_DIMEN[cur_expr], expr:LOWER_DIMEN[cur_expr],
expr:UPPER_DIMEN[e1], expr:LOWER_DIMEN[e1],
expr:UPPER_DIMEN[e2], expr:LOWER_DIMEN[e2])
;
PROCEDURE COMBINE(REFERENCE RECORD_POINTER(DIMENS_LIST) D1, D2, D3, D4, D5, D6);
α RECORD_POINTER(DIMENS_LIST) I1, I2, I3, I4, I5, I6;
I1 ← D1 ← NEW_RECORD(DIMENS_LIST); I2 ← D2 ← NEW_RECORD(DIMENS_LIST);
I3 ← D3; I4 ← D4; I5 ← D5; I6 ← D6;
WHILE I3≠NULL_RECORD OR I4≠NULL_RECORD OR I5≠NULL_RECORD OR I6≠NULL_RECORD DO
α RECORD_POINTER(DIMENS_LIST)T_D;
IF I3≠NULL_RECORD AND I6≠NULL_RECORD
AND DIMENS_LIST:VALUE[I3]=DIMENS_LIST:VALUE[I6]
THEN α I3 ← DIMENS_LIST:NEXT[I3]; I6 ← DIMENS_LIST:NEXT[I6] β
ELSE IF I4≠NULL_RECORD AND I5≠NULL_RECORD
AND DIMENS_LIST:VALUE[I4]=DIMENS_LIST:VALUE[I5]
THEN α I4 ← DIMENS_LIST:NEXT[I4]; I5 ← DIMENS_LIST:NEXT[I5] β
ELSE α INTEGER I_D; RECORD_POINTER(DIMENS_LIST)UPPER,LOWER;
BOOLEAN IS3, IS4, ISU;
INTEGER V3, V4, V5, V6, MIN_V;
! ?????; IF I3≠NULL_RECORD THEN V3 ← DIMENS_LIST:VALUE[I3] ELSE V3 ← 100;
IF I4≠NULL_RECORD THEN V4 ← DIMENS_LIST:VALUE[I4] ELSE V4 ← 100;
IF I5≠NULL_RECORD THEN V5 ← DIMENS_LIST:VALUE[I5] ELSE V5 ← 100;
IF I6≠NULL_RECORD THEN V6 ← DIMENS_LIST:VALUE[I6] ELSE V6 ← 100;
MIN_V ← V3 min V4 min V5 min V6; T_D ← NEW_RECORD(DIMENS_LIST);
DIMENS_LIST:VALUE[T_D] ← MIN_V;
IF V3=MIN_V THEN
α
DIMENS_LIST:NEXT[I1] ← T_D;
I3 ← DIMENS_LIST:NEXT[I3];
I1 ← T_D;
β
ELSE IF V5=MIN_V THEN
α
DIMENS_LIST:NEXT[I1] ← T_D;
I5 ← DIMENS_LIST:NEXT[I5];
I1 ← T_D;
β
ELSE IF V4=MIN_V THEN
α
DIMENS_LIST:NEXT[I2] ← T_D;
I4 ← DIMENS_LIST:NEXT[I4];
I2 ← T_D;
β
ELSE IF V6=MIN_V THEN
α
DIMENS_LIST:NEXT[I2] ← T_D;
I6 ← DIMENS_LIST:NEXT[I6];
I2 ← T_D;
β;
β;
β;
D1 ← DIMENS_LIST:NEXT[D1];
D2 ← DIMENS_LIST:NEXT[D2];
β;
! reduce, tmake_R;
PROCEDURE REDUCE;
α INTEGER CUR_OP_NUM; LABEL RAISE;
PROCEDURE FAIL_UP(INTEGER I; STRING S);
α RECORD_POINTER(EXPR)E;RECORD_POINTER(EXPR_LIST)EL;
ERROR(I,S&crlf&"I will reduce it to GARB_ID as default.");
E←NEW_RECORD(EXPR);
EL←NEW_RECORD(EXPR_LIST);
EXPR:TYPE[E]←scalar_VALUE;
EXPR:OP[E]←null;
EXPR:ID[E]←"GARB_ID";
EXPR_LIST:NEXT[EL]←EXPRS;
EXPR_LIST:EXP[EL]←E;
EXPRS←EL;
GO TO RAISE;
β;
procedure tmake_R;
α RECORD_POINTER (EXPR_LIST) CUR_PARTS,TEMP; ! TMAKE FOUND;
RECORD_POINTER (EXPR) E1,E2,E3;
IF EXPRS=NULL_RECORD OR EXPR_LIST:NEXT[EXPRS]=NULL_RECORD THEN
FAIL_UP(108,"Can't reduce expression.");
E1←EXPR_LIST:EXP[EXPRS];
EXPRS←EXPR_LIST:NEXT[EXPRS];
E2←EXPR_LIST:EXP[EXPRS];
IF EXPR:TYPE[E1]≠vector_VALUE THEN
α
E3←E1;
E1←E2;
E2←E3;
β;
IF EXPR:TYPE[E1]≠vector_VALUE OR EXPR:TYPE[E2]≠rot_VALUE THEN ERROR(109,"Type mismatch.");
TEMP←NEW_RECORD(EXPR_LIST);
EXPR_LIST:EXP[TEMP]←E1;
CUR_PARTS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[CUR_PARTS]←TEMP;
EXPR_LIST:EXP[CUR_PARTS]←E2;
E3←NEW_RECORD(EXPR);
EXPR:PARTS[E3]←CUR_PARTS;
EXPR:OP[E3]←"TMAKE";
EXPR:TYPE[E3]←trans_VALUE;
EXPR_LIST:EXP[EXPRS]←E3;
β;
! vmake_R, fmake_R;
procedure vmake_R;
α RECORD_POINTER (EXPR_LIST) CUR_PARTS,TEMP; ! VMAKE FOUND;
RECORD_POINTER (EXPR) CUR_EXPR;
INTEGER I;
FOR I←1 STEP 1 UNTIL 3 DO
α
IF EXPRS=NULL_RECORD THEN FAIL_UP(107,"Can't reduce expression.");
TEMP←EXPRS;
EXPRS←EXPR_LIST:NEXT[EXPRS];
EXPR_LIST:NEXT[TEMP]←CUR_PARTS;
CUR_PARTS←TEMP;
IF scalar_VALUE≠EXPR:TYPE[EXPR_LIST:EXP[CUR_PARTS]]
THEN ERROR(108,"Type mismatch");
β;
CUR_EXPR←NEW_RECORD(EXPR);
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
EXPR:OP[CUR_EXPR]←"VMAKE";
EXPR:TYPE[CUR_EXPR]←vector_VALUE;
TEMP←NEW_RECORD(EXPR_LIST);
EXPR_LIST:EXP[TEMP]←CUR_EXPR;
EXPR_LIST:NEXT[TEMP]←EXPRS;
EXPRS←TEMP;
β;
procedure fmake_R;
α RECORD_POINTER (EXPR_LIST) CUR_PARTS,TEMP; ! FMAKE FOUND;
RECORD_POINTER (EXPR) E1,E2,E3;
IF EXPRS=NULL_RECORD OR EXPR_LIST:NEXT[EXPRS]=NULL_RECORD THEN
FAIL_UP(108,"Can't reduce expression.");
E1←EXPR_LIST:EXP[EXPRS];
EXPRS←EXPR_LIST:NEXT[EXPRS];
E2←EXPR_LIST:EXP[EXPRS];
IF EXPR:TYPE[E1]≠vector_VALUE THEN
α E3←E1; E1←E2; E2←E3; β;
IF EXPR:TYPE[E1]≠vector_VALUE OR EXPR:TYPE[E2]≠rot_VALUE
THEN ERROR(109,"Type mismatch.");
TEMP←NEW_RECORD(EXPR_LIST);
EXPR_LIST:EXP[TEMP]←E1;
CUR_PARTS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[CUR_PARTS]←TEMP;
EXPR_LIST:EXP[CUR_PARTS]←E2;
E3←NEW_RECORD(EXPR);
EXPR:PARTS[E3]←CUR_PARTS;
EXPR:OP[E3]←"FMAKE";
EXPR:TYPE[E3]←trans_VALUE;
EXPR_LIST:EXP[EXPRS]←E3;
β;
! vvtrans_R, sneg_R;
procedure vvtrans_R;
α RECORD_POINTER (EXPR_LIST) CUR_PARTS,TEMP; ! VVVTRANS FOUND;
RECORD_POINTER (EXPR) CUR_EXPR;
INTEGER I;
FOR I←1 STEP 1 UNTIL 3 DO
α
IF EXPRS=NULL_RECORD THEN FAIL_UP(107,"Can't reduce expression.");
TEMP←EXPRS;
EXPRS←EXPR_LIST:NEXT[EXPRS];
EXPR_LIST:NEXT[TEMP]←CUR_PARTS;
CUR_PARTS←TEMP;
IF vector_VALUE≠EXPR:TYPE[EXPR_LIST:EXP[CUR_PARTS]]
THEN ERROR(108,"Type mismatch");
β;
CUR_EXPR←NEW_RECORD(EXPR);
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
EXPR:OP[CUR_EXPR]←"VVVTRANS";
EXPR:TYPE[CUR_EXPR]←rot_VALUE;
TEMP←NEW_RECORD(EXPR_LIST);
EXPR_LIST:EXP[TEMP]←CUR_EXPR;
EXPR_LIST:NEXT[TEMP]←EXPRS;
EXPRS←TEMP;
β;
procedure sneg_R;
α RECORD_POINTER (EXPR_LIST) CUR_PARTS,TEMP; ! "SNEG" FOUND;
RECORD_POINTER (EXPR) CUR_EXPR,E1,E2,E3;
IF EXPRS=NULL_RECORD THEN FAIL_UP(109,"Can't reduce expression.");
E1←EXPR_LIST:EXP[EXPRS];
IF EXPR:TYPE[E1]≠scalar_VALUE THEN ERROR(112,"You can only take the opposite of scalars."
&crlf&"Continue will pass the bug through.");
CUR_EXPR←NEW_RECORD(EXPR);
EXPR:OP[CUR_EXPR]←"SNEG";
CUR_PARTS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:EXP[CUR_PARTS]←E1;
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
EXPR:TYPE[CUR_EXPR]←scalar_VALUE;
EXPR:UPPER_DIMEN[CUR_EXPR]←EXPR:UPPER_DIMEN[E1];
EXPR:LOWER_DIMEN[CUR_EXPR]←EXPR:LOWER_DIMEN[E1];
EXPR_LIST:EXP[EXPRS]←CUR_EXPR;
β;
! rinv_R, sabs_R;
procedure rinv_R;
α RECORD_POINTER (EXPR_LIST) CUR_PARTS,TEMP; ! "RINV" FOUND;
RECORD_POINTER (EXPR) CUR_EXPR,E1;
IF EXPRS=NULL_RECORD THEN FAIL_UP(109,"Can't reduce expression.");
E1←EXPR_LIST:EXP[EXPRS];
CUR_EXPR←NEW_RECORD(EXPR);
IF EXPR:TYPE[E1]=rot_VALUE THEN
α
EXPR:OP[CUR_EXPR]←"RINV";
EXPR:TYPE[CUR_EXPR]←rot_VALUE;
β
ELSE IF EXPR:TYPE[E1]=trans_VALUE THEN
α
EXPR:OP[CUR_EXPR]←"TINVRT";
EXPR:TYPE[CUR_EXPR]←trans_VALUE;
β
ELSE ERROR(112,"You can only take the inverse of rotations and transforms."
&crlf&"Continue will pass bug through.");
CUR_PARTS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:EXP[CUR_PARTS]←E1;
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
EXPR:UPPER_DIMEN[CUR_EXPR]←EXPR:LOWER_DIMEN[E1];
EXPR:LOWER_DIMEN[CUR_EXPR]←EXPR:UPPER_DIMEN[E1];
EXPR_LIST:EXP[EXPRS]←CUR_EXPR;
β;
procedure sabs_R;
α ! "SABS" SHOULD BE HANDLED IN P_EXP; ERROR(-1,"PARSER ERROR"); β;
! plus_R;
procedure plus_R;
α RECORD_POINTER (EXPR_LIST) CUR_PARTS,TEMP; ! "+" FOUND;
RECORD_POINTER (EXPR) CUR_EXPR,E1,E2,E3;
IF EXPRS=NULL_RECORD THEN FAIL_UP(109,"Can't reduce expression.");
E1←EXPR_LIST:EXP[EXPRS];
EXPRS←EXPR_LIST:NEXT[EXPRS];
IF EXPRS=NULL_RECORD THEN FAIL_UP(110,"Can't reduce expression.");
E2←EXPR_LIST:EXP[EXPRS];
IF EXPR:TYPE[E1]≥EXPR:TYPE[E2] THEN α E3←E1; E1←E2; E2←E3; β;
TEMP←NEW_RECORD(EXPR_LIST);
CUR_PARTS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[CUR_PARTS]←TEMP;
EXPR_LIST:EXP[TEMP]←E1;
EXPR_LIST:EXP[CUR_PARTS]←E2;
CUR_EXPR←NEW_RECORD(EXPR);
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
CHECK("addition expression",EXPR:UPPER_DIMEN[E1],EXPR:LOWER_DIMEN[E1],
EXPR:UPPER_DIMEN[E2],EXPR:LOWER_DIMEN[E2]);
EXPR:UPPER_DIMEN[CUR_EXPR]←EXPR:UPPER_DIMEN[E1];
EXPR:LOWER_DIMEN[CUR_EXPR]←EXPR:LOWER_DIMEN[E1];
IF EXPR:TYPE[E1]=scalar_VALUE THEN
α
IF EXPR:TYPE[E2]≠scalar_VALUE THEN ERROR(109,"Type mismatch.");
EXPR:OP[CUR_EXPR]←"SADD";
EXPR:TYPE[CUR_EXPR]←scalar_VALUE;
β
ELSE IF EXPR:TYPE[E1]=vector_VALUE THEN
α
IF EXPR:TYPE[E2]=vector_VALUE THEN
α
EXPR:OP[CUR_EXPR]←"VADD";
EXPR:TYPE[CUR_EXPR]←vector_VALUE;
β
ELSE IF EXPR:TYPE[E2]=trans_VALUE THEN
α
EXPR:OP[CUR_EXPR]←"TVADD";
EXPR:TYPE[CUR_EXPR]←trans_VALUE;
β
β
ELSE ERROR(109,"Type mismatch");
EXPR_LIST:EXP[EXPRS]←CUR_EXPR;
β;
! minus_R;
procedure minus_R;
α RECORD_POINTER (EXPR_LIST) CUR_PARTS,TEMP; ! "SSUB" FOUND;
RECORD_POINTER (EXPR) CUR_EXPR,E1,E2,E3;
IF EXPRS=NULL_RECORD THEN FAIL_UP(109,"Can't reduce expression.");
E1←EXPR_LIST:EXP[EXPRS];
EXPRS←EXPR_LIST:NEXT[EXPRS];
IF EXPRS=NULL_RECORD THEN FAIL_UP(110,"Can't reduce expression.");
E2←EXPR_LIST:EXP[EXPRS];
IF EXPR:TYPE[E1]≠EXPR:TYPE[E2] THEN ERROR(111,"Type mismatch.");
TEMP←NEW_RECORD(EXPR_LIST);
CUR_PARTS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[CUR_PARTS]←TEMP;
EXPR_LIST:EXP[TEMP]←E1;
EXPR_LIST:EXP[CUR_PARTS]←E2;
CUR_EXPR←NEW_RECORD(EXPR);
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
CHECK("addition expression",EXPR:UPPER_DIMEN[E1],EXPR:LOWER_DIMEN[E1],
EXPR:UPPER_DIMEN[E2],EXPR:LOWER_DIMEN[E2]);
EXPR:UPPER_DIMEN[CUR_EXPR]←EXPR:UPPER_DIMEN[E1];
EXPR:LOWER_DIMEN[CUR_EXPR]←EXPR:LOWER_DIMEN[E1];
IF EXPR:TYPE[E1]=scalar_VALUE THEN
α
EXPR:OP[CUR_EXPR]←"SSUB";
EXPR:TYPE[CUR_EXPR]←scalar_VALUE;
β
ELSE IF EXPR:TYPE[E1]=vector_VALUE THEN
α
EXPR:OP[CUR_EXPR]←"VSUB";
EXPR:TYPE[CUR_EXPR]←vector_VALUE;
β
ELSE ERROR(109,"Type mismatch");
EXPR_LIST:EXP[EXPRS]←CUR_EXPR;
β;
! times_R;
procedure times_R;
α RECORD_POINTER (EXPR_LIST) CUR_PARTS,TEMP; ! "*" FOUND;
RECORD_POINTER (EXPR) CUR_EXPR,E1,E2,E3;
IF EXPRS=NULL_RECORD THEN FAIL_UP(109,"Can't reduce expression.");
E1←EXPR_LIST:EXP[EXPRS];
EXPRS←EXPR_LIST:NEXT[EXPRS];
IF EXPRS=NULL_RECORD THEN FAIL_UP(110,"Can't reduce expression.");
E2←EXPR_LIST:EXP[EXPRS];
IF EXPR:TYPE[E2]=vector_VALUE THEN α E3←E1; E1←E2; E2←E3; β;
TEMP←NEW_RECORD(EXPR_LIST);
CUR_PARTS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[CUR_PARTS]←TEMP;
EXPR_LIST:EXP[TEMP]←E1;
EXPR_LIST:EXP[CUR_PARTS]←E2;
CUR_EXPR←NEW_RECORD(EXPR);
COMBINE(EXPR:UPPER_DIMEN[CUR_EXPR],EXPR:LOWER_DIMEN[CUR_EXPR],
EXPR:UPPER_DIMEN[E1],EXPR:LOWER_DIMEN[E1],EXPR:UPPER_DIMEN[E2],
EXPR:LOWER_DIMEN[E2]);
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
IF EXPR:TYPE[E1]≤trans_VALUE
THEN CASE EXPR:TYPE[E1] OF
α "E1"
[scalar_VALUE] α
IF EXPR:TYPE[E2]≠scalar_VALUE THEN ERROR(109,"Type mismatch.");
EXPR:OP[CUR_EXPR]←"SMUL";
EXPR:TYPE[CUR_EXPR]←scalar_VALUE;
β;
[vector_VALUE] IF EXPR:TYPE[E2]≤trans_VALUE
THEN CASE EXPR:TYPE[E2] OF
α "E2"
[scalar_VALUE] α
EXPR:OP[CUR_EXPR]←"SVMUL";
EXPR:TYPE[CUR_EXPR]←vector_VALUE;
β;
[vector_VALUE] ERROR(109,"Type mismatch.");
[rot_VALUE] α
EXPR:OP[CUR_EXPR]←"RVMUL";
EXPR:TYPE[CUR_EXPR]←vector_VALUE;
β;
[frame_VALUE] ERROR(109,"Type mismatch.");
[plane_VALUE] ERROR(109,"Type mismatch.");
[trans_VALUE] α
EXPR:OP[CUR_EXPR]←"TVMUL";
EXPR:TYPE[CUR_EXPR]←vector_VALUE;
β
β "E2"
ELSE ERROR(109,"Type mismatch.");
[rot_VALUE] α
IF EXPR:TYPE[E2]≠rot_VALUE THEN ERROR(109,"Type mismatch.");
EXPR:OP[CUR_EXPR]←"RRMUL";
EXPR:TYPE[CUR_EXPR]←rot_VALUE;
β;
[frame_VALUE] ERROR(120,"Type mismatch.");
[plane_VALUE] ERROR(120,"Type mismatch.");
[trans_VALUE] α
IF EXPR:TYPE[E2]≠trans_VALUE THEN ERROR(109,"Type mismatch.");
EXPR:OP[CUR_EXPR]←"TTMUL";
EXPR:TYPE[CUR_EXPR]←trans_VALUE;
β
β "E1"
ELSE ERROR(109,"Type mismatch");
EXPR_LIST:EXP[EXPRS]←CUR_EXPR;
β;
! rot_R, wrt_R;
procedure rot_R;
α RECORD_POINTER (EXPR_LIST) CUR_PARTS,TEMP; ! "ROT" FOUND;
RECORD_POINTER (EXPR) CUR_EXPR,E1,E2,E3;
IF EXPRS=NULL_RECORD THEN FAIL_UP(109,"Can't reduce expression.");
E1←EXPR_LIST:EXP[EXPRS];
IF EXPR:TYPE[E1]≠scalar_VALUE THEN ERROR(109,"Type mismatch.");
EXPRS←EXPR_LIST:NEXT[EXPRS];
IF EXPRS=NULL_RECORD THEN FAIL_UP(110,"Can't reduce expression.");
E2←EXPR_LIST:EXP[EXPRS];
IF EXPR:TYPE[E2]≠vector_VALUE THEN ERROR(109,"Type mismatch.");
TEMP←NEW_RECORD(EXPR_LIST);
CUR_PARTS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[CUR_PARTS]←TEMP;
EXPR_LIST:EXP[TEMP]←E1;
EXPR_LIST:EXP[CUR_PARTS]←E2;
CUR_EXPR←NEW_RECORD(EXPR);
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
EXPR:OP[CUR_EXPR]←"AXW_ROTN";
EXPR:TYPE[CUR_EXPR]←rot_VALUE;
EXPR_LIST:EXP[EXPRS]←CUR_EXPR;
β;
procedure wrt_R;
α RECORD_POINTER (OP_LIST) OP_SAVE;
COMMENT
vector WRT frame
GETS TRANSLATED TO
(TVMUL (ORIENT frame) vector)
SO THIS PROCEDURE MERELY CHAANGES THE TOP OF THE OP_LIST
DOING NO REAL REDUCTION. THE REDUCTION IS THEN DONE ON THE
FOLLOWING TWO PASSES. (NOTE: THIS MEANS THAT THE PRECEDENCE
OF WRT IS DIFFERENT DEPENDING ON WHICH SIDE YOU SEE IT FROM.
;
OP_LIST:OP[OPS]←times_X;
OPSAVE←OPS;
OPS←NEW_RECORD(OP_LIST);
OP_LIST:NEXT[OPS]←OPSAVE;
OP_LIST:PRIORITY[OPS]← SPECIAL_INFO;
OP_LIST:NUM_OF_ARGS[OPS]←OP_NUM[orient_X];
OP_LIST:FUNC[OPS]←FALSE;
OP_LIST:ARG_DEP[OPS]←OP_BOOL[orient_X];
OP_LIST:OP[OPS]←orient_X;
COMMENT NOTE THAT THE END OF REDUCE (where the execution goes next)
WILL THROW AWAY THE TOP OP ON OP_LIST, SO WE'RE GOING TO
PUT ON A DUMMY OPERATOR;
OPSAVE←OPS;
OPS←NEW_RECORD(OP_LIST);
OP_LIST:NEXT[OPS]←OPSAVE;
β;
! →_R;
procedure →_R;
α RECORD_POINTER (EXPR_LIST) CUR_PARTS,TEMP; ! "→" FOUND;
RECORD_POINTER (EXPR) CUR_EXPR,E1,E2,E3;
IF EXPRS=NULL_RECORD THEN FAIL_UP(109,"Can't reduce expression.");
E1←EXPR_LIST:EXP[EXPRS];
EXPRS←EXPR_LIST:NEXT[EXPRS];
IF EXPRS=NULL_RECORD THEN FAIL_UP(110,"Can't reduce expression.");
E2←EXPR_LIST:EXP[EXPRS];
IF EXPR:TYPE[E1]≠EXPR:TYPE[E2] THEN ERROR(111,"Type mismatch.");
TEMP←NEW_RECORD(EXPR_LIST);
CUR_PARTS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[CUR_PARTS]←TEMP;
EXPR_LIST:EXP[TEMP]←E1;
EXPR_LIST:EXP[CUR_PARTS]←E2;
CUR_EXPR←NEW_RECORD(EXPR);
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
COMBINE(EXPR:UPPER_DIMEN[CUR_EXPR],EXPR:LOWER_DIMEN[CUR_EXPR],
EXPR:UPPER_DIMEN[E1],EXPR:LOWER_DIMEN[E1],EXPR:LOWER_DIMEN[E2],
EXPR:UPPER_DIMEN[E2]);
IF EXPR:TYPE[E1]=vector_VALUE THEN
α
EXPR:OP[CUR_EXPR]←"VTOV";
EXPR:TYPE[CUR_EXPR]←rot_VALUE;
β
ELSE IF EXPR:TYPE[E1]=trans_VALUE THEN
α
EXPR:OP[CUR_EXPR]←"FTOF";
EXPR:TYPE[CUR_EXPR]←trans_VALUE;
β
ELSE ERROR(109,"Type mismatch");
EXPR_LIST:EXP[EXPRS]←CUR_EXPR;
β;
! reduce execution starts here;
CUR_OP_NUM←OP_LIST:OP[OPS];
IF ¬(1 ≤ CUR_OP_NUM ≤ op_count)
THEN FAIL_UP(1030,"Trying to parse expression and found garbage.");
IF OP_BOOL[CUR_OP_NUM] THEN
CASE CUR_OP_NUM - first_true_op OF
α
redefine xx(str1, i1, boole, i2, i3, i4, str2)=[
ifc boole
thenc
redefine xx_temp=ifc "str2"=null thenc [str1] elsec [str2] endc & "_R";
xx_temp;
endc ];
operator_definitions;
β
ELSE α RECORD_POINTER(EXPR_LIST) CUR_PARTS,TEMP;
RECORD_POINTER (EXPR) CUR_EXPR;
INTEGER I;
FOR I←1 STEP 1 UNTIL OP_NUM[CUR_OP_NUM] DO
α
IF EXPRS=NULL_RECORD THEN FAIL_UP(107,"Can't reduce expression.");
TEMP←EXPRS;
EXPRS←EXPR_LIST:NEXT[EXPRS];
EXPR_LIST:NEXT[TEMP]←CUR_PARTS;
CUR_PARTS←TEMP;
IF TYPE_OF_ARGS[CUR_OP_NUM]≠EXPR:TYPE[EXPR_LIST:EXP[CUR_PARTS]]
AND TYPE_OF_ARGS[CUR_OP_NUM]≥0
THEN ERROR(108,"Type mismatch");
β;
CUR_EXPR←NEW_RECORD(EXPR);
CASE DIMEN_CHANGES[CUR_OP_NUM] OF
α
[ignore_dimen] ;
[same_dimen] α
EXPR:UPPER_DIMEN[CUR_EXPR]←EXPR:UPPER_DIMEN[EXPR_LIST:EXP[CUR_PARTS]];
EXPR:LOWER_DIMEN[CUR_EXPR]←EXPR:LOWER_DIMEN[EXPR_LIST:EXP[CUR_PARTS]];
β;
[inverse_dimen] α
EXPR:LOWER_DIMEN[CUR_EXPR]←EXPR:UPPER_DIMEN[EXPR_LIST:EXP[CUR_PARTS]];
EXPR:UPPER_DIMEN[CUR_EXPR]←EXPR:LOWER_DIMEN[EXPR_LIST:EXP[CUR_PARTS]];
β;
[check_dimen] α RECORD_POINTER(EXPR) E1,E2;
E1←EXPR_LIST:EXP[CUR_PARTS];
E2←EXPR_LIST:EXP[EXPR_LIST:NEXT[CUR_PARTS]];
CHECK("expression",EXPR:UPPER_DIMEN[E1],EXPR:LOWER_DIMEN[E1],EXPR:UPPER_DIMEN[E2],
EXPR:LOWER_DIMEN[E2]);
EXPR:UPPER_DIMEN[CUR_EXPR]←EXPR:UPPER_DIMEN[E1];
EXPR:LOWER_DIMEN[CUR_EXPR]←EXPR:LOWER_DIMEN[E1];
β;
[multiply_dimen] COMBINE(EXPR:UPPER_DIMEN[CUR_EXPR],EXPR:LOWER_DIMEN[CUR_EXPR],
EXPR:UPPER_DIMEN[EXPR_LIST:EXP[CUR_PARTS]],
EXPR:LOWER_DIMEN[EXPR_LIST:EXP[CUR_PARTS]],
EXPR:UPPER_DIMEN[EXPR_LIST:EXP[EXPR_LIST:NEXT[CUR_PARTS]]],
EXPR:LOWER_DIMEN[EXPR_LIST:EXP[EXPR_LIST:NEXT[CUR_PARTS]]]);
[divide_dimen] COMBINE(EXPR:UPPER_DIMEN[CUR_EXPR],EXPR:LOWER_DIMEN[CUR_EXPR],
EXPR:UPPER_DIMEN[EXPR_LIST:EXP[CUR_PARTS]],
EXPR:LOWER_DIMEN[EXPR_LIST:EXP[CUR_PARTS]],
EXPR:LOWER_DIMEN[EXPR_LIST:EXP[EXPR_LIST:NEXT[CUR_PARTS]]],
EXPR:UPPER_DIMEN[EXPR_LIST:EXP[EXPR_LIST:NEXT[CUR_PARTS]]])
β;
EXPR:PARTS[CUR_EXPR]←CUR_PARTS;
EXPR:OP[CUR_EXPR]←OP_ARRAY[CUR_OP_NUM];
IF RESULT_TYPE[CUR_OP_NUM]≥0 THEN
EXPR:TYPE[CUR_EXPR]←RESULT_TYPE[CUR_OP_NUM] ELSE
EXPR:TYPE[CUR_EXPR]←EXPR:TYPE[EXPR_LIST:EXP[CUR_PARTS]];
TEMP←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[TEMP]←EXPRS;
EXPR_LIST:EXP[TEMP]←CUR_EXPR;
EXPRS←TEMP;
β;
RAISE: OPS←OP_LIST:NEXT[OPS];
β;
! printexpr;
RECURSIVE PROCEDURE PRINTEXPR(RECORD_POINTER (EXPR) E);
IF EQU(EXPR:OP[E],null) THEN OUTEXPR←OUTEXPR&EXPR:ID[E]
ELSE α RECORD_POINTER (EXPR_LIST) SUBS;
OUTEXPR←OUTEXPR&"("&EXPR:OP[E];
SUBS←EXPR:PARTS[E];
WHILE SUBS≠NULL DO
α
OUTEXPR←OUTEXPR&" ";
PRINTEXPR(EXPR_LIST:EXP[SUBS]);
SUBS←EXPR_LIST:NEXT[SUBS];
β;
OUTEXPR←OUTEXPR&")";
β;
! p_exp2;
! PARSE EXPRESSIONS AND SAVE PARSED STRUCTURE INTERNALLY FOR LATER PRINTING;
PROCEDURE P_EXP2;
α RECORD_POINTER (ID_LIST) POINT; LABEL FLUSH;
PROCEDURE F_EXP(INTEGER IP; STRING SP);
α RECORD_POINTER(EXPR)E;
ERROR(IP,SP&crlf&"Continue will attempt to flush expression.");
WHILE ( TYPE_OF_TOKEN=id_token
OR (EQU(TOKEN,"(") AND ¬OP_EXPECTED)
OR TYPE_OF_TOKEN=numeric_token
OR (TYPE_OF_TOKEN=special_token
AND ((operator_beg ≤ TYPE_OF_RES_WORD ≤ operator_end)
OR TYPE_OF_RES_WORD=declare_RES)))
DO GET_TOKEN;
OPS←NULL_RECORD;
if exprs≠null_record then
α
E←NEW_RECORD(EXPR);
EXPR:TYPE[E]←scalar_VALUE;
EXPR:ID[E]←"GARB_ID";
EXPR_LIST:NEXT[EXPRS]←NULL_RECORD;
EXPR_LIST:EXP[EXPRS]←E;
β;
GO TO FLUSH;
β;
! parse_special;
procedure parse_special;
α "parse_special" integer j;
define expected_ops=[
xx([(], -1, -1, false, false)
xx([|], sabs_X, -1, true, false)
xx([-], sneg_X, vector_RES, false, false)
xx([/], rinv_X, vector_RES, false, false)
xx(NOT, not_X, not_RES, false, false)
xx([¬], not_X, not_RES, false, false)
xx(VVTRANS, vvtrans_X, vector_RES, false, true)
xx(ROT, rot_X, vector_RES, true, true)
xx(VVROT, vvrot_X, vector_RES, false, true)
xx(VDOT, vdot_X, vector_RES, false, true)
xx(ANGLE, angle_X, vector_RES, false, true)
];
define
op_case=0;
redefine xx(token, op_num, prior, arg_dep, func)=[
redefine op_case=op_case+1;];
expected_ops;
redefine xx(token, op_num, prior, arg_dep, func)=["token",];
preload_array(
expected_name, expected_ops, [own string], 0, op_case);
redefine xx(token, op_num, prior, arg_dep, func)=[op_num,];
preload_array(
expected_X, expected_ops, [own integer], 0, op_case);
redefine xx(token, op_num, prior, arg_dep, func)=[prior,];
preload_array(
expected_prior, expected_ops, [own integer], 0, op_case);
redefine xx(token, op_num, prior, arg_dep, func)=[arg_dep,];
preload_array(
expected_arg, expected_ops, [own boolean], 0, op_case);
redefine xx(token, op_num, prior, arg_dep, func)=[func,];
preload_array(
expected_func, expected_ops, [own boolean], 0, op_case);
OPSAVE←OPS; OPS←NEW_RECORD(OP_LIST);
OP_LIST:NEXT[OPS]←OPSAVE;
OP_LIST:PRIORITY[OPS] ← SPECIAL_INFO;
for j←0 step 1 until op_case-1 do if equ(token,expected_name[j]) then done;
if j ≤ op_case-1
then
α integer k;
OP_LIST:PRIORITY[OPS] ← expected_prior[j];
OP_LIST:OP[OPS] ← k ← expected_X[j];
OP_LIST:NUM_OF_ARGS[OPS] ← if k<0 then 1 else op_num[k];
op_list:count[ops] ← 0;
OP_LIST:ARG_DEP[OPS] ← expected_arg[j];
op_list:func[ops] ← expected_func[j];
β
ELSE IF EQU(TOKEN,"⊗")
THEN
α
EXP1←NEW_RECORD(EXPR);
EXPR:TYPE[EXP1]←trans_VALUE;
EXPR:OP[EXP1]←null;
IF EQU(CURRENT_FRAME,null) THEN
ERROR(1111,"⊗ used outside of MOVE, AFFIX, or UNAFFIX statement is illegal.");
EXPR:ID[EXP1]←CURRENT_FRAME;
EXPR:UPPER_DIMEN[EXP1]←distance_dimens;
EXPRSAVE←EXPRS;
EXPRS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[EXPRS]←EXPRSAVE;
EXPR_LIST:EXP[EXPRS]←EXP1;
OPS←OP_LIST:NEXT[OPS];
OP_EXPECTED←TRUE;
β
ELSE IF TYPE_OF_RES_WORD=declare_RES
THEN
α "declare_RES"
case special_info of
α "special_info"
[vector_VALUE] α ! VMAKE FOUND;
OP_LIST:OP[OPS] ← vmake_X;
OP_LIST:NUM_OF_ARGS[OPS] ← op_num[vmake_X];
β;
[frame_VALUE] α ! FMAKE FOUND;
OP_LIST:OP[OPS] ← fmake_X;
OP_LIST:NUM_OF_ARGS[OPS] ← op_num[fmake_X];
β;
[trans_VALUE] α ! TMAKE FOUND;
OP_LIST:OP[OPS] ← tmake_X;
OP_LIST:NUM_OF_ARGS[OPS] ← op_num[tmake_X];
β;
[0] F_EXP(103,"Illegal operator.");
[scalar_VALUE] F_EXP(103,"Illegal operator.");
[rot_VALUE] F_EXP(103,"Illegal operator.");
[plane_VALUE] F_EXP(103,"Illegal operator.")
β "special_info";
OP_LIST:COUNT[OPS]←0;
OP_LIST:ARG_DEP[OPS]←FALSE;
OP_LIST:FUNC[OPS]←TRUE;
β "declare_RES"
ELSE if special_info
then
α
OP_LIST:OP[OPS]←SPECIAL_INFO;
OP_LIST:ARG_DEP[OPS]←OP_BOOL[SPECIAL_INFO];
OP_LIST:NUM_OF_ARGS[OPS]←OP_NUM[SPECIAL_INFO];
β
else f_exp(200, "Doesn't make sense.");
β "parse_special";
! p_exp2 execution begins here, p_exp;
OP_EXPECTED←FALSE; EXPRS←ops←EXP1←EXP2←EXP3←NULL_RECORD; OUTEXPR←null;
GET_TOKEN;
WHILE ( TYPE_OF_TOKEN=id_token
OR (EQU(TOKEN,"(") AND ¬OP_EXPECTED)
OR TYPE_OF_TOKEN=numeric_token
OR (TYPE_OF_TOKEN=special_token
AND ((operator_beg ≤ TYPE_OF_RES_WORD ≤ operator_end)
OR TYPE_OF_RES_WORD=declare_RES)))
DO
α "while"
IF OP_EXPECTED THEN
α "op_expected"
IF EQU(TOKEN,"ROT") THEN
α
TYPE_OF_TOKEN←special_token;
TYPE_OF_RES_WORD←trans_RES;
SPECIAL_INFO←rot_X;
β;
IF TYPE_OF_TOKEN>special_token OR EQU(TOKEN,"(")
THEN F_EXP(101,"Operation needed here.");
α "termin_check" integer match, j; string str;
match ← -1; j←0;
for str ← ")", ",", "|" do
if equ(str, token)
then α match ← j; done β
else j ← j+1;
if match ≥ 0
then case match of
α "match"
! ")"; α
WHILE OPS≠NULL_RECORD AND OP_LIST:OP[OPS]≠-1 DO REDUCE;
IF OPS=NULL_RECORD THEN done "while";
OPS←OP_LIST:NEXT[OPS];
IF OPS≠NULL_RECORD AND OP_LIST:FUNC[OPS]=TRUE THEN REDUCE;
β;
! ","; α
WHILE OPS≠NULL_RECORD AND OP_LIST:OP[OPS]≠-1 DO REDUCE;
IF OPS=NULL THEN done "while";
OP_EXPECTED←FALSE;
β;
! "|"; α integer e;
WHILE OPS≠NULL_RECORD AND OP_LIST:OP[OPS]≠17 DO REDUCE;
IF OPS=NULL_RECORD
THEN F_EXP(105,"Mismatched vertical paren.");
OPS←OP_LIST:NEXT[OPS];
EXP1←NEW_RECORD(EXPR);
EXPR:PARTS[EXP1]←NEW_RECORD(EXPR_LIST);
EXPR_LIST:EXP[EXPR:PARTS[EXP1]]←EXPR_LIST:EXP[EXPRS];
EXPR:UPPER_DIMEN[EXP1]
← EXPR:UPPER_DIMEN[EXPR_LIST:EXP[EXPRS]];
EXPR:LOWER_DIMEN[EXP1]
← EXPR:LOWER_DIMEN[EXPR_LIST:EXP[EXPRS]];
EXPR:TYPE[EXP1]←scalar_VALUE;
IF (e ← EXPR:TYPE[EXPR_LIST:EXP[EXPRS]])=scalar_VALUE
THEN EXPR:OP[EXP1]←"SABS";
IF E=vector_VALUE THEN EXPR:OP[EXP1]←"VMAGN";
IF E=rot_VALUE THEN EXPR:OP[EXP1]←"RMAGN";
if e≠scalar_value or e≠vector_value or e≠rot_value
then ERROR(106,"Type mismatch for |.|.");
EXPR_LIST:EXP[EXPRS]←EXP1;
β
β "match"
ELSE
α
IF TYPE_OF_RES_WORD=0
THEN F_EXP(1000,"Sorry, OP not implemented yet.");
WHILE OPS≠NULL_RECORD AND OP_LIST:PRIORITY[OPS]≥TYPE_OF_RES_WORD
DO REDUCE;
OPSAVE←OPS;
OPS←NEW_RECORD(OP_LIST);
OP_LIST:NEXT[OPS]←OPSAVE;
OP_LIST:PRIORITY[OPS]←TYPE_OF_RES_WORD;
OP_LIST:NUM_OF_ARGS[OPS]←OP_NUM[SPECIAL_INFO];
OP_LIST:FUNC[OPS]←FALSE;
OP_LIST:ARG_DEP[OPS]←OP_BOOL[SPECIAL_INFO];
OP_LIST:OP[OPS]←SPECIAL_INFO;
OP_EXPECTED←FALSE;
β
β "termin_check"
β "op_expected"
ELSE case TYPE_OF_TOKEN of
α "type_of_token"
[id_token] α RECORD_POINTER (ID_LIST) PPPP;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE (POINT≠NULL AND ¬EQU(ID_LIST:NAME[POINT],TOKEN))
DO POINT←ID_LIST:NEXT[POINT];
IF POINT=NULL THEN
α
ERROR(102,"Undefined ID "&TOKEN);
POINT ← SYMBOL_TABLE[HASH("GARB_ID",hasher)];
TOKEN←"GARB_ID";
β;
EXP1←NEW_RECORD(EXPR);
EXPR:TYPE[EXP1]←ID_LIST:TYPE[POINT];
EXPR:UPPER_DIMEN[EXP1]←DIMEN_DEFS[ID_LIST:DIMEN_P[POINT]];
EXPR:LOWER_DIMEN[EXP1]←DIMEN_DEFS2[ID_LIST:DIMEN_P[POINT]];
EXPR:OP[EXP1]←null;
EXPR:ID[EXP1]←TOKEN;
EXPRSAVE←EXPRS;
EXPRS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[EXPRS]←EXPRSAVE;
EXPR_LIST:EXP[EXPRS]←EXP1;
OP_EXPECTED←TRUE;
β;
[numeric_token] α
EXP1←NEW_RECORD(EXPR);
EXPR:TYPE[EXP1]←scalar_VALUE;
EXPR:OP[EXP1]←null;
EXPR:ID[EXP1]←TOKEN;
EXPRSAVE←EXPRS;
EXPRS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:NEXT[EXPRS]←EXPRSAVE;
EXPR_LIST:EXP[EXPRS]←EXP1;
OP_EXPECTED←TRUE;
β;
[special_token] parse_special;
[string_token] F_EXP(100,"Illegal expression.")
β "type_of_token";
GET_TOKEN;
β "while";
FLUSH:
REJECT←TRUE;
WHILE OPS≠NULL_RECORD DO REDUCE;
IF EXPRS=NULL
THEN
α
ERROR(107,"Empty expression, continue will insert GARBID");
EXPRS←NEW_RECORD(EXPR_LIST);
EXPR_LIST:EXP[EXPRS]←NEW_RECORD(EXPR);
EXPR:ID[EXPR_LIST:EXP[EXPRS]]←"GARB_ID";
β
ELSE IF EXPR_LIST:NEXT[EXPRS]≠NULL THEN ERROR(107,"Can't reduce expression.");
UPPER_D←EXPR:UPPER_DIMEN[EXPR_LIST:EXP[EXPRS]];
LOWER_D←EXPR:LOWER_DIMEN[EXPR_LIST:EXP[EXPRS]];
PRINTEXPR(EXPR_LIST:EXP[EXPRS]);
EXP_TYPE←EXPR:TYPE[EXPR_LIST:EXP[EXPRS]];
β;
! PARSE EXPRESSIONS AND IMMEDIATELY PRINT EXPRESSION IN ALCODE FORM;
PROCEDURE P_EXP;
α
P_EXP2;
PRINT(OUTEXPR);
β;
! P_condition;
! CONDITION FINDER - NOT YET INCLUDED;
BOOLEAN PROCEDURE P_CONDITION(INTEGER PP;STRING PRELUDE);
α STRING COND,OP; LABEL FLUSH;
PROCEDURE F_STATE(VALUE INTEGER IP; VALUE STRING SP);
α STRING CLOSE; INTEGER I;
FOR I←1 STEP 1 UNTIL PP DO CLOSE←CLOSE&")";
SPACING←SPACING-PP;
PRINT(CLOSE);
ERROR(IP,SP&crlf&"Continue will flush statement.");
WHILE ¬EQU(TOKEN,";") DO GET_TOKEN;
REJECT←TRUE;
GO TO FLUSH;
β;
GET_TOKEN;
IF TYPE_OF_TOKEN≠special_token OR TYPE_OF_RES_WORD≠0 THEN
F_STATE(44,"Bogus condition monitor.");
IF SPECIAL_INFO=nil_CM
THEN COND←TOKEN
ELSE
α INTEGER FORCE_TYPE;
! YOU MIGHT WANT TO INCORPORATE ALL OF THIS INTO P_EXP2;
FORCE_TYPE←SPECIAL_INFO;
COND←"(FORCE ";
GET_TOKEN;
IF ¬EQU(TOKEN,"(") THEN
ERROR(1201,"Need left paren here. Continue will insert it.");
IF FORCE_TYPE=torque_CM
THEN COND←COND&"NILVECT "
ELSE
α
P_EXP2;
IF EXP_TYPE≠vector_VALUE THEN F_STATE(1202,"Need vector here.");
COND←COND&OUTEXPR&" ";
β;
IF FORCE_TYPE=force_or_torque_CM THEN
α
GET_TOKEN;
IF ¬EQU(TOKEN,",") THEN ERROR(1203,"Need comma here. Continue will insert it.");
β;
IF FORCE_TYPE=force_CM
THEN COND←COND&"NILVECT"
ELSE
α
P_EXP2;
IF EXP_TYPE≠vector_VALUE THEN F_STATE(1202,"Need vector here.");
COND←COND&OUTEXPR;
β;
GET_TOKEN;
IF ¬EQU(TOKEN,")") THEN
ERROR(1201,"Need right paren here. Continue will insert it.");
COND←COND&")";
β;
GET_TOKEN;
IF TYPE_OF_TOKEN≠special_token OR TYPE_OF_RES_WORD≠order_RES
THEN F_STATE(44,"Bogus condition monitor.");
OP←OP_ARRAY[SPECIAL_INFO];
PRINT(PRELUDE&" ("&OP&" "&COND);
SPACING←SPACING+1;
P_EXP;
IF EXP_TYPE≠scalar_VALUE THEN ERROR(49,"Need scalar quantity here.");
PRINT(")");
SPACING←SPACING-1;
RETURN(FALSE);
FLUSH: RETURN(TRUE);
β;
! P_clauses, T_gen;
PROCEDURE P_CLAUSES;
α BOOLEAN T; LABEL FLUSH;
PROCEDURE F_STATE(VALUE INTEGER IP; VALUE STRING SP);
α STRING CLOSE; INTEGER I;
SPACING←SPACING-2;
PRINT("))");
ERROR(IP,SP&crlf&"Continue will flush statement.");
WHILE ¬EQU(TOKEN,";") DO GET_TOKEN;
REJECT←TRUE;
GO TO FLUSH;
β;
T←TRUE;
GET_TOKEN;
WHILE T DO
IF TYPE_OF_TOKEN≠special_token THEN
α RECORD_POINTER (ID_LIST) POINT; STRING LABL;
! LABELED CONDITION MONITOR FOUND;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE POINT≠NULL AND ¬EQU(TOKEN,ID_LIST:NAME[POINT]) DO
POINT←ID_LIST:NEXT[POINT];
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠cm_label_VALUE THEN
ERROR(51,"Illegal or undefined ID. Can only handle Condition Monitor ID here.");
LABL←TOKEN&" ";
GET_TOKEN;
IF ¬EQU(TOKEN,":") THEN
ERROR_REJECT(53,"Need semicolon here. Continue will insert it.");
GET_TOKEN;
IF ¬EQU(TOKEN,"ON") THEN
ERROR_REJECT(52,"Need ON here for a condition monitor.");
P_CONDITION(2,"("&LABL&"ON");
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN
ERROR_REJECT(45,"Need DO here. Continue will insert it.");
P_STATEMENT;
SPACING←SPACING-1;
PRINT(")");
GET_TOKEN;
β
ELSE IF TYPE_OF_RES_WORD=on_RES THEN
α
! UNLABELED CONDITION MONITOR FOUND;
P_CONDITION(2,"("&"ON");
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN
ERROR_REJECT(45,"Need DO here. Continue will insert it.");
P_STATEMENT;
SPACING←SPACING-1;
PRINT(")");
GET_TOKEN;
β
ELSE IF EQU(TOKEN,"(") THEN
α INTEGER C; STRING TEMP;
! LEFT PAREN FOUND - STAIGHT TRANSFER;
C←1;
TEMP←"(";
WHILE C>0 DO
α
TEMP←TEMP&READ(paren_cr_break);
IF BRCHAR="(" THEN C←C+1
ELSE IF BRCHAR=")" THEN C←C-1 ELSE
α
PRINT(TEMP);
TEMP←NULL;
β;
β;
PRINT(TEMP);
GET_TOKEN;
β
ELSE IF ¬(move_beg ≤ TYPE_OF_RES_WORD ≤ move_end) THEN
α
! END OF MOVE STATEMENT FOUND;
REJECT←TRUE;
T←FALSE;
β
ELSE CASE TYPE_OF_RES_WORD - move_beg OF
α
[via_X] α
! VIA CLAUSE FOUND;
PRINT("(VIA ");
SPACING←SPACING+1;
P_EXP;
GET_TOKEN;
IF EQU(TOKEN,",") THEN
α;
SPACING←SPACING-1;
PRINT(")");
WHILE EQU(TOKEN,",") DO
α
PRINT("(VIA ");
SPACING←SPACING+1; P_EXP; SPACING←SPACING-1;
PRINT(")");
GET_TOKEN;
β;
β
ELSE α BOOLEAN V_FOUND,D_FOUND,CONTIN;
CONTIN←TRUE;
IF EQU(TOKEN,"WITH") THEN
WHILE ¬(V_FOUND ∧ D_FOUND) ∧ CONTIN DO
α
GET_TOKEN;
IF V_FOUND ∧ EQU(TOKEN,"VELOCITY") THEN
F_STATE(3011,"Multiple VELOCITY specification found in WITH clause.")
ELSE IF EQU(TOKEN,"VELOCITY") THEN
α
PRINT("(VELOCITY ");
GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(3014,"Need = here.");
SPACING←SPACING+1;
P_EXP;
SPACING←SPACING-1;
PRINT(")");
IF EXP_TYPE≠vector_VALUE THEN
α
SPACING←SPACING-1;
PRINT(")");
F_STATE(3012,"Need a vector expression here.");
β;
V_FOUND←TRUE;
GET_TOKEN;
IF ¬EQU(TOKEN,",") THEN CONTIN←FALSE;
β
ELSE IF D_FOUND ∧ EQU(TOKEN,"DURATION") THEN
F_STATE(3013,"Multiple DURATION specification found in WITH clause.")
ELSE IF EQU(TOKEN,"DURATION") THEN
α
GET_TOKEN;
IF ¬(EQU(TOKEN,"=") ∨ EQU(TOKEN,"<") ∨ EQU(TOKEN,">")) THEN
ERROR_REJECT(3014,"Need =,<, or > here.");
PRINT("(DURATION " & TOKEN & " ");
SPACING←SPACING+1;
P_EXP;
SPACING←SPACING-1;
PRINT(")");
IF EXP_TYPE≠scalar_VALUE THEN
α
SPACING←SPACING-1;
PRINT(")");
F_STATE(3012,"Need a scalar expression here.");
β;
D_FOUND←TRUE;
GET_TOKEN;
IF ¬EQU(TOKEN,",") THEN CONTIN←FALSE;
β
ELSE CONTIN←FALSE;
β;
IF EQU(TOKEN,"THEN") THEN
α;
PRINT("(THEN");
SPACING←SPACING+1;
P_STATEMENT;
SPACING←SPACING-1;
PRINT(")");
GET_TOKEN;
β;
SPACING←SPACING-1;
PRINT(")");
β;
β;
[with_X] α;
GET_TOKEN;
IF TYPE_OF_TOKEN≠special_token THEN F_STATE(3017,"Illegal WITH clause.")
ELSE IF TYPE_OF_RES_WORD=arrival_RES THEN
α
PRINT("(" & TOKEN);
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(3022,"Need = here.");
GET_TOKEN;
IF EQU(TOKEN,"NILDEPROACH") THEN PRINT("NILDEPROACH")
ELSE IF EQU(TOKEN,"DEPROACH") THEN
α
PRINT("(DEPR");
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"(") THEN ERROR_REJECT(3019,"Need left paren here.");
P_EXP;
IF EXP_TYPE≠frame_exp_VALUE THEN F_STATE(3020,"Need frame exp here.");
GET_TOKEN;
IF ¬EQU(TOKEN,")") THEN ERROR_REJECT(3021,"Need right paren here.");
SPACING←SPACING-1;
PRINT(")");
β
ELSE α
REJECT←TRUE;
P_EXP;
IF EXP_TYPE≠scalar_VALUE ∧ EXP_TYPE≠vector_VALUE ∧ EXP_TYPE≠trans_VALUE THEN
ERROR(3018,"Type mismatch for DEPROACH.");
β;
SPACING←SPACING-1;
PRINT(")");
β
ELSE IF EQU(TOKEN,"FORCE") THEN F_STATE(3015,"SORRY, CAN'T HANDLE FORCE " &
"CLAUSES YET.")
ELSE IF EQU(TOKEN,"DURATION") THEN
α;
GET_TOKEN;
IF ¬(EQU(TOKEN,"=") ∨ EQU(TOKEN,"<") ∨ EQU(TOKEN,">")) THEN
ERROR_REJECT(3014,"Need =,<, or > here.");
PRINT("(DURATION " & TOKEN & " ");
SPACING←SPACING+1;
P_EXP;
SPACING←SPACING-1;
PRINT(")");
IF EXP_TYPE≠scalar_VALUE THEN
F_STATE(3012,"Need a scalar expression here.");
β
ELSE F_STATE(3016,"Illegal WITH clause.");
GET_TOKEN;
β
β;
FLUSH:
β;
STRING PROCEDURE T_GEN;
α
T_COUNT←T_COUNT+1;
RETURN("_T"&CVS(T_COUNT));
β;
! P_statement, begin_P;
RECURSIVE PROCEDURE P_STATEMENT;
α "P_STATEMENT"
LABEL FLUSH,TRY_AGAIN; STRING LABL; INTEGER LABEL_TYPE;
PROCEDURE F_STATE(VALUE INTEGER PP,IP; VALUE STRING SP);
α STRING CLOSE; INTEGER I;
FOR I←1 STEP 1 UNTIL PP DO CLOSE←CLOSE&")";
SPACING←SPACING-PP;
PRINT(CLOSE);
ERROR(IP,SP&crlf&"Continue will flush statement.");
WHILE ¬EQU(TOKEN,";") DO GET_TOKEN;
REJECT←TRUE;
GO TO FLUSH;
β;
procedure begin_P;
α INTEGER SAVE_DEC_NUM;
BLOCK_LEVEL←BLOCK_LEVEL+1;
SAVE_DEC_NUM←DEC_NUM; DEC_NUM←0;
PRINT("("&LABL&"BL");
SPACING←SPACING+1;
WHILE ¬EQU(TOKEN,"END") DO
α
P_STATEMENT;
GET_TOKEN;
IF TYPE_OF_TOKEN≠special_token OR TYPE_OF_RES_WORD≠end_RES
THEN ERROR_REJECT(4,
"Need semicolon before this token ⊂"&TOKEN&"⊃")
ELSE IF EQU(TOKEN,"COEND") THEN
α
ERROR(5,"Block ends with COEND" & cr
& "Continue to view as end");
TOKEN←"END";
β;
β;
FOR I←1 STEP 1 UNTIL DEC_NUM DO
α
SYMBOL_TABLE[HASH(ID_LIST:NAME[TOP_ID],hasher)]
← ID_LIST:NEXT[TOP_ID];
TOP_ID←ID_LIST:LINK[TOP_ID];
β;
DEC_NUM←SAVE_DEC_NUM;
SPACING←SPACING-1;
BLOCK_LEVEL←BLOCK_LEVEL-1;
PRINT(")");
β;
! cobegin_P, end_P, open_paren_P;
procedure cobegin_P;
α INTEGER SAVE_DEC_NUM; ! "COBEGIN" INDICATES BEGINNING OF COBLOCK;
BLOCK_LEVEL←BLOCK_LEVEL+1;
SAVE_DEC_NUM←DEC_NUM; DEC_NUM←0;
PRINT("("&LABL&"CO");
SPACING←SPACING+1;
WHILE ¬EQU(TOKEN,"COEND") DO
α
P_STATEMENT;
GET_TOKEN;
IF TYPE_OF_TOKEN≠special_token OR TYPE_OF_RES_WORD≠END_RES
THEN ERROR_REJECT(4,"Need semicolon before this token ⊂"
& TOKEN & "⊃")
ELSE IF EQU(TOKEN,"END") THEN
α
ERROR(5,"Block ends with END" & cr
& "Continue to view as COEND");
TOKEN←"COEND";
β;
β;
FOR I←1 STEP 1 UNTIL DEC_NUM DO
α
SYMBOL_TABLE[HASH(ID_LIST:NAME[TOP_ID],hasher)]←ID_LIST:NEXT
[TOP_ID];
TOP_ID←ID_LIST:LINK[TOP_ID];
β;
DEC_NUM←SAVE_DEC_NUM;
SPACING←SPACING-1;
BLOCK_LEVEL←BLOCK_LEVEL-1;
PRINT(")");
β;
procedure end_P;
α ! SEMICOLON FOUND - NOOP;
REJECT←TRUE;
β;
procedure open_paren_P;
α INTEGER C; STRING TEMP;
! LEFT PAREN FOUND - STAIGHT TRANSFER;
C←1;
TEMP←"(";
WHILE C>0 DO
α
TEMP←TEMP&READ(paren_cr_break);
IF BRCHAR="(" THEN C←C+1
ELSE IF BRCHAR=")" THEN C←C-1 ELSE
α
PRINT(TEMP);
TEMP←NULL;
β;
β;
PRINT(TEMP);
β;
! declare_P;
procedure declare_P;
α STRING BUILD_OUT; INTEGER TYPE1; INTEGER DIM;
BUILD_OUT←"("&LABL&DEC_NAME[SPECIAL_INFO];
IF SPECIAL_INFO≠frame_VALUE
THEN TYPE1←SPECIAL_INFO ELSE TYPE1←trans_VALUE;
GET_TOKEN;
IF TYPE_OF_TOKEN=special_token AND TYPE_OF_RES_WORD=metric_RES THEN
α
DIM←SPECIAL_INFO;
GET_TOKEN;
β;
WHILE ¬EQU(TOKEN,";") DO
α RECORD_POINTER (ID_LIST) POINT,SCAN_POINT;
INTEGER INDEX;
IF TYPE_OF_TOKEN≠id_token THEN F_STATE(0,6,"Illegal token or attempt "
&"to declare reserved word.");
INDEX←HASH(TOKEN,hasher);
SCAN_POINT←SYMBOL_TABLE[INDEX];
WHILE SCAN_POINT≠NULL_RECORD AND
ID_LIST:BLOCK_LEVEL_OF_DEFN[SCAN_POINT]=BLOCK_LEVEL DO
α
IF EQU(ID_LIST:NAME[SCAN_POINT],TOKEN) THEN
ERROR(3001,"⊂"&TOKEN&"⊃ is multiply defined "
&"in this block.");
SCAN_POINT←ID_LIST:NEXT[SCAN_POINT];
β;
BUILD_OUT←BUILD_OUT&" "&TOKEN;
POINT←NEW_RECORD(ID_LIST);
ID_LIST:NAME[POINT]←TOKEN;
ID_LIST:TYPE[POINT]←TYPE1;
ID_LIST:DIMEN_P[POINT]←DIM;
ID_LIST:BLOCK_LEVEL_OF_DEFN[POINT]←BLOCK_LEVEL;
ID_LIST:NEXT[POINT]←SYMBOL_TABLE[INDEX];
SYMBOL_TABLE[INDEX]←POINT;
ID_LIST:LINK[POINT]←TOP_ID;
TOP_ID←POINT;
DEC_NUM←DEC_NUM+1;
GET_TOKEN;
IF EQU(TOKEN,";") THEN REJECT←TRUE
ELSE IF ¬EQU(TOKEN,",") THEN
ERROR_REJECT(7,"Missing comma.");
GET_TOKEN;
β;
REJECT←TRUE;
PRINT(BUILD_OUT&")");
β;
! global_P;
procedure global_P;
α INTEGER O_DIM;
PRINT("("&LABL&"GVAR"); SPACING←SPACING+1; GET_TOKEN;
IF TYPE_OF_TOKEN=special_token AND TYPE_OF_RES_WORD=metric_RES
THEN α O_DIM←SPECIAL_INFO; GET_TOKEN; β;
WHILE ¬EQU(TOKEN,";") DO
α STRING BUILD_OUT; INTEGER TYPE1; INTEGER DIM;
DIM←O_DIM;
IF TYPE_OF_RES_WORD≠declare_RES
THEN F_STATE(1,8,"Need variable type here.");
TYPE_OF_RES_WORD←-1; ! reset to get WHILE LOOP started;
BUILD_OUT←"("&DEC_NAME[SPECIAL_INFO]; TYPE1←SPECIAL_INFO;
GET_TOKEN;
IF TYPE_OF_TOKEN=special_token AND TYPE_OF_RES_WORD=metric_RES
THEN α DIM←SPECIAL_INFO; GET_TOKEN; β;
WHILE ¬EQU(TOKEN,";")AND TYPE_OF_RES_WORD≠declare_RES DO
α RECORD_POINTER (ID_LIST) POINT,SCAN_POINT;
INTEGER INDEX;
IF TYPE_OF_TOKEN≠id_token THEN F_STATE(1,6,"Illegal token"
&" or attempt to declare reserved word.");
INDEX←HASH(TOKEN,hasher);
WHILE SCAN_POINT≠NULL_RECORD AND
ID_LIST:BLOCK_LEVEL_OF_DEFN[SCAN_POINT]=BLOCK_LEVEL DO
α
IF EQU(ID_LIST:NAME[SCAN_POINT],TOKEN) THEN
ERROR(3001,"⊂"&TOKEN&"⊃ is multiply defined "
&"in this block.");
SCAN_POINT←ID_LIST:NEXT[SCAN_POINT];
β;
BUILD_OUT←BUILD_OUT&" "&TOKEN;
POINT←NEW_RECORD(ID_LIST);
ID_LIST:NAME[POINT]←TOKEN;
ID_LIST:TYPE[POINT]←TYPE1;
ID_LIST:DIMEN_P[POINT]←DIM;
ID_LIST:BLOCK_LEVEL_OF_DEFN[POINT]←BLOCK_LEVEL;
ID_LIST:NEXT[POINT]←SYMBOL_TABLE[INDEX];
SYMBOL_TABLE[INDEX]←POINT;
ID_LIST:LINK[POINT]←TOP_ID;
TOP_ID←POINT;
DEC_NUM←DEC_NUM+1;
GET_TOKEN;
IF EQU(TOKEN,";")OR TYPE_OF_RES_WORD=declare_RES
THEN REJECT←TRUE
ELSE IF ¬EQU(TOKEN,",")
THEN ERROR_REJECT(7,"Missing comma.");
GET_TOKEN;
β;
PRINT(BUILD_OUT&")");
β;
REJECT←TRUE;
SPACING←SPACING-1;
PRINT(")");
β;
! if_P, plan_P, while_P;
procedure if_P;
α ! IF STATEMENT FOUND;
IF PLAN_STATEMENT THEN PRINT("("&LABL&"CIF") ELSE PRINT("("&LABL&"IF");
PLAN_STATEMENT←FALSE;
SPACING←SPACING+1;
P_EXP;
IF EXP_TYPE≠boole_VALUE AND EXP_TYPE≠scalar_VALUE
THEN F_STATE(1,10,"Conditional for IF must be boolean");
GET_TOKEN;
IF ¬EQU(TOKEN,"THEN") THEN
ERROR_REJECT(9,"Missing THEN. Continue will insert it.");
P_STATEMENT;
GET_TOKEN;
IF EQU(TOKEN,"ELSE") THEN P_STATEMENT ELSE REJECT←TRUE;
SPACING←SPACING-1;
PRINT(")");
β;
procedure plan_P;
α ! PLAN STATEMENT FOUND;
GET_TOKEN;
REJECT←TRUE;
PLAN_STATEMENT←TRUE;
IF ¬(EQU(TOKEN,"IF") OR EQU(TOKEN,"WRITE") OR EQU(TOKEN,"ERROR")
OR EQU(TOKEN,"FOREACH")) THEN F_STATE(0,11,"Illegal token to "&
"follow PLAN: "&TOKEN);
P_STATEMENT;
PLAN_STATEMENT←FALSE;
β;
procedure while_P;
α ! WHILE STATEMENT FOUND;
PRINT("("&LABL&"WH");
SPACING←SPACING+1;
P_EXP;
IF EXP_TYPE≠boole_VALUE AND EXP_TYPE≠scalar_VALUE
THEN F_STATE(0,11,"Conditional for WHILE must be boolean or sclar.");
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN
ERROR_REJECT(12,"Missing DO. Continue will insert it.");
P_STATEMENT;
SPACING←SPACING-1;
PRINT(")");
β;
! for_P;
procedure for_P;
α RECORD_POINTER(ID_LIST) POINT; ! FOR STATEMENT FOUND;
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token THEN ERROR(13,"Need scalar ID here.");
T←TRUE;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE T AND POINT≠NULL DO
IF ID_LIST:NAME[POINT]=TOKEN THEN T←FALSE
ELSE POINT←ID_LIST:NEXT[POINT];
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠scalar_VALUE THEN
α
ERROR(13,"Need scalar ID here.");
POINT ← SYMBOL_TABLE[HASH("GARB_ID",hasher)];
β;
PRINT("("&LABL&"FO "&ID_LIST:NAME[POINT]);
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"←") THEN
ERROR_REJECT(14,"Need left arrow here for FOR statement.");
P_EXP;
IF EXP_TYPE≠scalar_VALUE THEN
ERROR_REJECT(15,"Need scalar value here.");
GET_TOKEN;
IF ¬EQU(TOKEN,"STEP") THEN
ERROR_REJECT(16,"Need STEP here.");
P_EXP;
IF EXP_TYPE≠scalar_VALUE THEN
ERROR_REJECT(15,"Need scalar value here.");
GET_TOKEN;
IF ¬EQU(TOKEN,"UNTIL") THEN
ERROR_REJECT(17,"Need UNTIL here.");
P_EXP;
IF EXP_TYPE≠scalar_VALUE THEN
ERROR_REJECT(15,"Need scalar value here.");
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN
ERROR_REJECT(18,"Need DO here.");
P_STATEMENT;
SPACING←SPACING-1;
PRINT(")");
β;
! move_P;
procedure move_P;
α RECORD_POINTER(ID_LIST) POINT; ! MOVE STATEMENT FOUND;
GET_TOKEN;
IF EQU(TOKEN,"BLUE") THEN TOKEN←"BARM"
ELSE IF EQU(TOKEN,"YELLOW") THEN TOKEN←"YARM" ELSE
α
IF TYPE_OF_TOKEN≠id_token THEN ERROR(19,"Need frame ID here.");
T←TRUE;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE T AND POINT≠NULL DO
IF ID_LIST:NAME[POINT]=TOKEN THEN T←FALSE
ELSE POINT←ID_LIST:NEXT[POINT];
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠trans_VALUE THEN
ERROR(13,"Need frame ID here.");
β;
CURRENT_FRAME←TOKEN;
PRINT("("&LABL&"MO "&TOKEN);
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"TO") THEN
ERROR_REJECT(19,"Need TO here.");
P_EXP;
IF EXP_TYPE≠trans_VALUE THEN
ERROR_REJECT(20,"Need either a FRAME or TRANSFORM expression here.");
CURRENT_FRAME←null;
P_CLAUSES;
SPACING←SPACING-1;
PRINT(")");
β;
! affix_p;
procedure affix_p;
α STRING SAVE1,SAVE2,TRANS;
RECORD_POINTER(ID_LIST) POINT;
! AFFIX STATEMENT FOUND;
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token THEN
ERROR_REJECT(19,"Need frame ID here.");
T←TRUE;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE T AND POINT≠NULL DO
IF ID_LIST:NAME[POINT]=TOKEN THEN T←FALSE
ELSE POINT←ID_LIST:NEXT[POINT];
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠trans_VALUE THEN
ERROR(13,"Need frame ID here.");
CURRENT_FRAME←TOKEN;
SAVE1←TOKEN;
GET_TOKEN;
IF ¬EQU(TOKEN,"TO") THEN
ERROR_REJECT(21,"Need TO here. Continue will insert it.");
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token THEN ERROR(19,"Need frame ID here.");
T←TRUE;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE T AND POINT≠NULL DO
IF ID_LIST:NAME[POINT]=TOKEN THEN T←FALSE
ELSE POINT←ID_LIST:NEXT[POINT];
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠trans_VALUE THEN
ERROR(13,"Need frame ID here.");
SAVE2←TOKEN;
GET_TOKEN;
IF EQU(TOKEN,"BY") THEN
α
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token THEN ERROR(19,"Need TRANS ID here.");
T←TRUE;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE T AND POINT≠NULL DO
IF ID_LIST:NAME[POINT]=TOKEN THEN T←FALSE
ELSE POINT←ID_LIST:NEXT[POINT];
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠trans_VALUE THEN
ERROR(13,"Need trans ID here.");
TRANS←TOKEN;
β ELSE α
TRANS←T_GEN;
PRINT("(TVAR "&TRANS&")");
REJECT←TRUE;
β;
GET_TOKEN;
IF EQU(TOKEN,"AT") THEN
α
PRINT("("&LABL&"AFFIX "&SAVE1&" "&SAVE2&" "&TRANS);
SPACING←SPACING+1;
P_EXP;
GET_TOKEN;
IF EQU(TOKEN,"RIGIDLY")THEN PRINT("RIGIDLY)")
ELSE IF EQU(TOKEN,"NONRIGIDLY")THEN PRINT("NONRIGIDLY)")
ELSE α PRINT("NONRIGIDLY)");REJECT←TRUE; β;
SPACING←SPACING-1;
β ELSE α STRING HOW;
IF EQU(TOKEN,"RIGIDLY") OR EQU(TOKEN,"NONRIGIDLY") THEN
HOW←TOKEN ELSE α HOW←"NONRIGIDLY";REJECT←TRUE;β;
PRINT("("&LABL&"AFFIX "&SAVE1&" "&SAVE2&" "&TRANS&" () "&HOW&")");
β;
CURRENT_FRAME←null;
β;
! unfix_P, signal_P;
procedure unfix_P;
α STRING SAVE1;
RECORD_POINTER(ID_LIST) POINT;
! UNAFFIX STATEMENT FOUND;
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token THEN ERROR(19,"Need frame ID here.");
T←TRUE;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE T AND POINT≠NULL DO
IF ID_LIST:NAME[POINT]=TOKEN THEN T←FALSE
ELSE POINT←ID_LIST:NEXT[POINT];
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠trans_VALUE THEN
ERROR(13,"Need frame ID here.");
CURRENT_FRAME←TOKEN;
SAVE1←TOKEN;
GET_TOKEN;
IF ¬EQU(TOKEN,"FROM") THEN
ERROR_REJECT(20,"Need FROM here.");
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token THEN ERROR(19,"Need frame ID here.");
T←TRUE;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE T AND POINT≠NULL DO
IF ID_LIST:NAME[POINT]=TOKEN THEN T←FALSE
ELSE POINT←ID_LIST:NEXT[POINT];
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠trans_VALUE THEN
ERROR(13,"Need frame ID here.");
PRINT("("&LABL&"UNFIX"&" "&SAVE1&" "&TOKEN&")");
CURRENT_FRAME←null;
β;
procedure signal_P;
α RECORD_POINTER(ID_LIST) POINT;
! SIGNAL STATEMENT FOUND;
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token THEN ERROR(19,"Need event ID here.");
T←TRUE;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE T AND POINT≠NULL DO
IF ID_LIST:NAME[POINT]=TOKEN THEN T←FALSE
ELSE POINT←ID_LIST:NEXT[POINT];
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠event_VALUE THEN
ERROR(21,"Need event ID here.");
PRINT("("&LABL&"EV "&TOKEN&" +)");
β;
! wait_P;
procedure wait_P;
α RECORD_POINTER(ID_LIST) POINT;
! WAIT STATEMENT FOUND;
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token THEN ERROR(20,"Need event ID here.");
T←TRUE;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE T AND POINT≠NULL DO
IF ID_LIST:NAME[POINT]=TOKEN THEN T←FALSE
ELSE POINT←ID_LIST:NEXT[POINT];
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠event_VALUE THEN
ERROR(21,"Need event ID here.");
PRINT("("&LABL&"EV "&TOKEN&" -)");
β;
! when_P;
procedure when_P;
α RECORD_POINTER (ID_LIST) POINT; STRING VAR, ALSO_OP, CHG_LAB;
BOOLEAN TEMP;
! WHEN STATEMENT FOUND;
GET_TOKEN;
IF ¬EQU(TOKEN,"CHANGING") THEN
ERROR_REJECT(30,"Need word CHANGING here for a WHEN CHANGING statement."&
" Continue will insert it.");
GET_TOKEN;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE POINT≠NULL AND ¬EQU(ID_LIST:NAME[POINT],TOKEN) DO
POINT←ID_LIST:NEXT[POINT];
IF POINT=NULL THEN ERROR(31,"Undefined ID");
VAR←TOKEN;
GET_TOKEN;
IF EQU(TOKEN,"ALSO") THEN ALSO_OP←"ALSO_DO"
ELSE IF EQU(TOKEN,"DON'T") THEN ALSO_OP←"ALSO_DON'T"
ELSE IF EQU(TOKEN,"ONLY") THEN ALSO_OP←"ALSO_ONLY"
ELSE ERROR(32,"Illegal ALSO_OP");
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN
ERROR_REJECT(33,"Need DO here. Continue will insert it.");
GET_TOKEN;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE POINT≠NULL AND ¬EQU(ID_LIST:NAME[POINT],TOKEN) DO
POINT←ID_LIST:NEXT[POINT];
IF POINT=NULL THEN TEMP←TRUE
ELSE IF ID_LIST:TYPE[POINT]=ch_label_VALUE THEN TEMP←FALSE
! ?????; ELSE IF ID_LIST:TYPE[POINT]>world_VALUE THEN
α
ERROR(34,"Can only handle CH_LABEL here. Continue while delete this label.");
TEMP←TRUE;
β
ELSE TEMP←TRUE;
IF TEMP THEN
α
CHG_LAB←T_GEN;
PRINT("(CHGLAB "&CHG_LAB&")");
REJECT←TRUE;
CHANGER_HEAD←CHG_LAB&" CHG ";
β
ELSE α
CHG_LAB←TOKEN;
GET_TOKEN;
IF EQU(TOKEN,":") THEN
α
TEMP←TRUE;
CHANGER_HEAD←CHG_LAB&" CHG ";
β
ELSE α
REJECT←TRUE;
PRINT("("&ALSO_OP&" "&VAR&" "&CHG_LAB&")");
β;
β;
IF TEMP THEN
α
PRINT("("&ALSO_OP&" "&VAR);
SPACING←SPACING+1;
P_STATEMENT;
SPACING←SPACING-1;
PRINT(")");
β;
β;
! dump_P;
procedure dump_P;
α RECORD_POINTER (ID_LIST) POINT; BOOLEAN T; STRING IDSTRING;
! DUMP STATEMENT FOUND;
IDSTRING←null;
GET_TOKEN;
T←TRUE;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE POINT≠NULL AND ¬EQU(ID_LIST:NAME[POINT],TOKEN) DO
POINT←ID_LIST:NEXT[POINT];
IF POINT≠NULL AND ID_LIST:TYPE[POINT]=world_VALUE THEN
PRINT("("&LABL&"DBD "&TOKEN&")")
ELSE WHILE T DO
α
! ?????; IF POINT=NULL OR ID_LIST:TYPE[POINT]>event_VALUE THEN
ERROR(35,"Undefined ID.");
IDSTRING←IDSTRING&" "&TOKEN;
GET_TOKEN;
IF EQU(TOKEN,"IN") THEN T←FALSE
ELSE α
IF ¬EQU(TOKEN,",") THEN
ERROR_REJECT(36,"Need comma or IN here. Continue wil insert a comma.");
GET_TOKEN;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE POINT≠NULL AND ¬EQU(ID_LIST:NAME[POINT],TOKEN) DO
POINT←ID_LIST:NEXT[POINT];
β;
β;
IF ¬T THEN
α
GET_TOKEN;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE POINT≠NULL AND ¬EQU(TOKEN,ID_LIST:NAME[POINT]) DO
POINT←ID_LIST:NEXT[POINT];
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠world_VALUE THEN
ERROR(37,"Need a world ID here.");
PRINT("("&LABL&"PVL "&IDSTRING&TOKEN&")");
β;
β;
! assert_P;
procedure assert_P;
α RECORD_POINTER (ID_LIST) POINT; STRING IDSTRING,COM;
INTEGER VAR_TYPE;
! ASSERT OR DENY STATEMENT FOUND;
COM←TOKEN;
GET_TOKEN;
IF EQU(TOKEN,"FORM") THEN
α
IDSTRING←null;
GET_TOKEN;
IF ¬EQU(TOKEN,"(") THEN
ERROR_REJECT(37,"Need left paren here. Continue will insert it.");
WHILE ¬EQU(TOKEN,")") DO
α
GET_TOKEN;
IDSTRING←IDSTRING&TOKEN&" ";
GET_TOKEN;
IF ¬EQU(TOKEN,")") AND ¬EQU(TOKEN,",") THEN
ERROR_REJECT(38,"Need either comma or right paren here."&
" Continue will insert a comma.");
β;
GET_TOKEN;
IF EQU(TOKEN,"IN") THEN
α
GET_TOKEN;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE POINT≠NULL AND ¬EQU(TOKEN,ID_LIST:NAME[POINT]) DO
POINT←ID_LIST:NEXT[POINT];
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠world_VALUE THEN
ERROR(39,"Need world ID here.");
PRINT("("&LABL&COM&" (SF "&IDSTRING&") "&TOKEN&")");
β
ELSE α
REJECT←TRUE;
PRINT("("&LABL&COM&" (SF "&IDSTRING&"))");
β;
β
ELSE α STRING VAR;
POINT←SYMBOL_TABLE[HASH(VAR←TOKEN,hasher)];
WHILE POINT≠NULL AND ¬EQU(ID_LIST:NAME[POINT],TOKEN) DO
POINT←ID_LIST:NEXT[POINT];
! ?????; IF POINT=NULL OR ID_LIST:TYPE[POINT]>trans_VALUE THEN
α
ERROR(40,"Need variable ID here.");
POINT←SYMBOL_TABLE[HASH("GARB_ID",hasher)];
β;
VAR_TYPE←ID_LIST:TYPE[POINT];
GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR(41,"Sorry, can only handle equality right now.");
PRINT("("&LABL&COM&" (AF "&VAR&" = ");
SPACING←SPACING+1;
P_EXP;
SPACING←SPACING-1;
IF VAR_TYPE≠EXP_TYPE THEN ERROR(42,"Types don't match on equality test.");
GET_TOKEN;
IF EQU(TOKEN,"IN") THEN
α
GET_TOKEN;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE POINT≠NULL AND ¬EQU(TOKEN,ID_LIST:NAME[POINT]) DO
POINT←ID_LIST:NEXT[POINT];
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠world_VALUE THEN
ERROR(39,"Need world ID here.");
PRINT(") "&TOKEN&")");
β
ELSE α
REJECT←TRUE;
PRINT("))");
β;
β;
β;
! on_P, reference_P, parseshit_P, open_P;
procedure on_P;
α RECORD_POINTER (ID_LIST) POINT;
! CONDITION MONITER FOUND;
IF ¬EQU(LABL,null) AND LABEL_TYPE≠cm_label_VALUE THEN
α
ERROR(43,"Must have condition monitor label if any label is uesed. Continue will flush label.");
LABL←null;
β;
P_CONDITION(0,"("&LABL&"ON");
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"DO") THEN
ERROR_REJECT(45,"Need DO here. Continue will insert it.");
P_STATEMENT;
SPACING←SPACING-1;
PRINT(")");
β;
procedure reference_P;
α RECORD_POINTER (ID_LIST) POINT; ! NEW WORLD DEF;
GET_TOKEN;
IF ¬EQU(TOKEN,"POINT") THEN
ERROR_REJECT(46,"Need POINT here for a REFERENCE POINT statement.");
GET_TOKEN;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE POINT≠NULL AND ¬EQU(TOKEN,ID_LIST:NAME[POINT]) DO
POINT←ID_LIST:NEXT[POINT];
IF POINT=NULL OR ID_LIST:TYPE[POINT]≠world_VALUE THEN
ERROR(47,"Need a world variable here.");
PRINT("("&LABL&"NW "&TOKEN&")");
β;
procedure parseshit_P;
α ! PARSESHIT FOUND;
ifc debug_compile thenc BAIL; elsec usererr(0, 1, "Parseshit"); endc
β;
procedure open_P;
α STRING HAND; ! OPEN/CLOSE FOUND;
RECORD_POINTER (ID_LIST) POINT;
GET_TOKEN;
IF EQU(TOKEN,"BHAND") OR EQU(TOKEN,"YHAND") THEN HAND←TOKEN
ELSE IF EQU(TOKEN,"BLUE") THEN HAND←"BHAND"
ELSE IF EQU(TOKEN,"YELLOW") THEN HAND←"YHAND"
ELSE ERROR(48,"Unknown hand.");
GET_TOKEN;
IF ¬EQU(TOKEN,"TO") THEN
ERROR_REJECT(49,"Need TO here.");
PRINT("("&LABL&"MO "&HAND);
SPACING←SPACING+1;
P_EXP;
IF EXP_TYPE≠scalar_VALUE THEN ERROR(121,"Need scalar quantity here.");
SPACING←SPACING-1;
PRINT(")");
β;
! center_P, stop_P;
procedure center_P;
α ! CENTER FOUND;
GET_TOKEN;
IF EQU(TOKEN,"BLUE") THEN PRINT("("&LABL&"CENTER BARM)")
ELSE IF EQU(TOKEN,"YELLOW") THEN PRINT("("&LABL&"CENTER YARM)")
ELSE IF EQU(TOKEN,"YARM") OR EQU(TOKEN,"BARM") THEN PRINT("("&LABL&"CENTER "&TOKEN&")")
ELSE ERROR(48,"Unknown hand.");
β;
procedure stop_P;
α ! STOP FOUND;
GET_TOKEN;
IF EQU(TOKEN,"BLUE") THEN PRINT("("&LABL&"STOP BLUE)")
ELSE IF EQU(TOKEN,"YELLOW") THEN PRINT("("&LABL&"STOP YELLOW)")
ELSE ERROR(48,"Unknown hand.");
β;
! define_P;
procedure define_P;
α INTEGER PARAM_COUNT, HASH_ENTRY; STRING MACRO_NAME;
BOOLEAN SPECIAL_DELIMS; RECORD_POINTER (MACRO_LIST) MAC_POINT;
RECORD_POINTER (PARAM_LIST) TOP_PARAM, NEW_PARAM, LAST_PARAM;
procedure macro_delimiters(boolean turn_on);
α string chr1, chr2;
if turn_on
then if top_delimiters≠null_record
then
α
chr1 ← delimiter_list:d1[top_delimiters];
chr2 ← delimiter_list:d2[top_delimiters];
β
else chr1 ← chr2 ← dquote
else chr1 ← chr2 ← null;
delimiter_1 ← chr1; delimiter_2 ← chr2;
SETBREAK(macro_delimiter_break, chr1 & chr2, NULL, "ISN");
SETBREAK(word_R_break, TABLE1 & chr1, NULL, "INRK");
SETBREAK(word_S_break, TABLE1 & chr1, NULL, "INSK");
β;
do α "define_macro"
SPECIAL_DELIMS←FALSE; PARAM_COUNT←0; GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token
THEN F_STATE(0,56,"Can only define unreserved ID's.");
MACRO_NAME←TOKEN; GET_TOKEN;
IF EQU(TOKEN,"(") THEN
α "macro_parameters"
TOP_PARAM←LAST_PARAM←NEW_RECORD(PARAM_LIST);
WHILE ¬EQU(TOKEN,")") DO
α
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token
THEN F_STATE(0,57,"Can only use unreserved ID's as parameter names.");
PARAM_COUNT←PARAM_COUNT+1; NEW_PARAM←NEW_RECORD(PARAM_LIST);
PARAM_LIST:NEXT[LAST_PARAM]←NEW_PARAM;
PARAM_LIST:ID[NEW_PARAM]←TOKEN; LAST_PARAM←NEW_PARAM;
GET_TOKEN;
IF ¬EQU(TOKEN,")") AND ¬EQU(TOKEN,",") THEN
α
ERROR(58,"Need either comma or right paren here.");
REJECT←TRUE; TOKEN←")";
β;
β;
TOP_PARAM←PARAM_LIST:NEXT[TOP_PARAM];
GET_TOKEN;
β "macro_parameters";
IF TYPE_OF_TOKEN=string_token THEN
α "special_delimiters" RECORD_POINTER (DELIMITER_LIST) NEW_DEL;
SPECIAL_DELIMS←TRUE;
IF TYPE_OF_TOKEN≠string_token THEN F_STATE(0,52,"Need string here.");
IF LENGTH(TOKEN)≠2 THEN F_STATE(0,53,"Need string of length 2.");
push_delimiters(token);
β "special_delimiters";
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(59,"Need = here.");
macro_delimiters(true); GET_TOKEN; macro_delimiters(false);
IF TYPE_OF_TOKEN≠string_token THEN F_STATE(0,60,"Need string here.");
MAC_POINT←NEW_RECORD(MACRO_LIST);
MACRO_LIST:ID[MAC_POINT]←MACRO_NAME;
MACRO_LIST:VALUE[MAC_POINT]←TOKEN;
MACRO_LIST:NUM[MAC_POINT]←PARAM_COUNT;
MACRO_LIST:PARAMS[MAC_POINT]←TOP_PARAM;
HASH_ENTRY←HASH(MACRO_NAME,hasher);
MACRO_LIST:NEXT[MAC_POINT]←MACRO_TABLE[HASH_ENTRY];
IF MACRO_TABLE[HASH_ENTRY]≠NULL THEN MACRO_LIST:LAST[MACRO_TABLE[HASH_ENTRY]]
←MAC_POINT;
MACRO_TABLE[HASH_ENTRY]←MAC_POINT;
IF SPECIAL_DELIMS THEN
α
IF NULL=TOP_DELIMITERS
THEN F_STATE(0,54,"Can't unstack special delimiters!");
TOP_DELIMITERS←DELIMITER_LIST:NEXT[TOP_DELIMITERS];
β;
get_token;
β "define_macro"
until ¬equ(token, ",");
if equ(token, ";") then reject ← true;
β;
! require_P;
procedure require_P;
α ! REQUIRE STATEMENT FOUND;
GET_TOKEN;
IF ¬(require_beg ≤ TYPE_OF_RES_WORD ≤ require_end)
THEN F_STATE(0,51, "Illegal token after require.")
ELSE
CASE TYPE_OF_RES_WORD - require_beg OF
α
[source_file_X] α RECORD_POINTER (SOURCE_LIST) NEW_SOURCE;
NEW_SOURCE←NEW_RECORD(SOURCE_LIST);
SOURCE_LIST:CHAN[NEW_SOURCE]←CHANIN;
SOURCE_LIST:NUM[NEW_SOURCE]←0;
SOURCE_LIST:FILE_NAME[NEW_SOURCE]←INFILE;
SOURCE_LIST:NEXT[NEW_SOURCE]←TOP_SOURCE;
TOP_SOURCE←NEW_SOURCE;
GET_TOKEN;
INFILE←TOKEN;
GET_TOKEN;
REJECT←TRUE;
SOURCE_LIST:PN[NEW_SOURCE]←PAGENUM;
SOURCE_LIST:LN[NEW_SOURCE]←LINENUM;
SOURCE_LIST:CUR_STRING[NEW_SOURCE]←CURLINE;
SOURCE_LIST:CUR_STRINGR[NEW_SOURCE]←CURLINER;
OPEN(CHANIN←GETCHAN,"DSK",0,4,0,COUNT,BRCHAR,EOF);
LOOKUP(CHANIN,INFILE,eof);
IF eof THEN
ERROR(55,"Lookup failed on required file - "&INFILE);
CURLINE←CURLINER←NULL; pagenum ← linenum ← 0;
if typed_page_num then outstr(crlf);
file_indent(sourcelvl ← sourcelvl+1);
outstr(infile & " 1"); typed_page_num ← true;
β;
[delimiters_X] α RECORD_POINTER (DELIMITER_LIST) NEW_DEL;
GET_TOKEN;
IF TYPE_OF_TOKEN≠string_token THEN F_STATE(0,52,"Need string here.");
IF LENGTH(TOKEN)≠2 THEN F_STATE(0,53,"Need string of length 2.");
push_delimiters(token);
β;
[unstack_delimiters_X] IF NULL=TOP_DELIMITERS
THEN F_STATE(0,54,"Sorry, delimiter stack empty.")
ELSE TOP_DELIMITERS←DELIMITER_LIST:NEXT[TOP_DELIMITERS];
[replace_delimiters_X] α
GET_TOKEN;
IF TYPE_OF_TOKEN≠string_token
THEN F_STATE(0,52,"Need string here.");
IF LENGTH(TOKEN)≠2
THEN F_STATE(0,53,"Need string of length 2.");
delimiter_list:d1[top_delimiters] ← lop(token);
delimiter_list:d2[top_delimiters] ← lop(token);
β
β;
β;
! dimension_P;
procedure dimension_P;
α ! DIMENSION STATEMENT FOUND;
INTEGER FILL_POINT; RECORD_POINTER(DIMENS_LIST) D1,D2,D3,D4,D5;
BOOLEAN TOP; INTEGER COUNT;
IF DIMEN_NUM≥16 THEN F_STATE(0,66,"Sorry, can't handle this many dimensions.");
TOP←TRUE; COUNT←0;
D1←D3←NEW_RECORD(DIMENS_LIST); D2←D4←NEW_RECORD(DIMENS_LIST);
GET_TOKEN;
IF TYPE_OF_TOKEN≠id_token THEN F_STATE(0,61,"Can only use unreserved ID's for dimensions.");
FILL_POINT←HASH(TOKEN,hasher);
WHILE RESERVED[FILL_POINT]≠NULL_RECORD DO FILL_POINT←(FILL_POINT+1)MOD hasher;
RESERVED[FILL_POINT]←TOKEN;
COM_TYPE[FILL_POINT]←metric_RES+hasher*(DIMEN_NUM+1);
GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN ERROR_REJECT(62,"Need = here.");
GET_TOKEN;
WHILE ¬EQU(TOKEN,";") DO
α
IF EQU(TOKEN,"INV") THEN
α
GET_TOKEN;
IF ¬EQU(TOKEN,"(")
THEN ERROR_REJECT(63,"Need ( here.");
TOP←¬TOP;
COUNT←COUNT+1;
GET_TOKEN;
β;
IF TYPE_OF_RES_WORD≠metric_RES OR SPECIAL_INFO>metric_max
THEN F_STATE(0,64,"Need basic dimension here, e.g."
&" TIME, MASS, or ANGLE.");
D5←NEW_RECORD(DIMENS_LIST);
DIMENS_LIST:VALUE[D5]←SPECIAL_INFO;
IF TOP
THEN α DIMENS_LIST:NEXT[D3]←D5; D3←D5; β
ELSE α DIMENS_LIST:NEXT[D4]←D5; D4←D5; β;
GET_TOKEN;
IF EQU(TOKEN,"(") AND COUNT=0
THEN F_STATE(0,65,"Parens don't match.")
ELSE IF EQU(TOKEN,")") THEN COUNT←COUNT-1
ELSE IF EQU(TOKEN,";") AND COUNT≠0 THEN F_STATE(0,65,"Parens don't match.")
ELSE IF EQU(TOKEN,"/") THEN
α
GET_TOKEN;
IF ¬EQU(TOKEN,"(") THEN ERROR_REJECT(63,"Need ( here.");
TOP←¬TOP;
COUNT←COUNT+1;
β
ELSE IF ¬EQU(TOKEN,";") AND ¬EQU(TOKEN,"*") THEN
F_STATE(0,65,"Need ; here.");
IF ¬EQU(TOKEN,";") THEN GET_TOKEN;
β;
D5←DIMENS_LIST:NEXT[D1];
WHILE D5≠NULL_RECORD DO
α
D4←DIMENS_LIST:NEXT[D5];
WHILE D4≠NULL_RECORD DO
α INTEGER ITEMP;
IF DIMENS_LIST:VALUE[D5]>DIMENS_LIST:VALUE[D4] THEN
α
ITEMP←DIMENS_LIST:VALUE[D4];
DIMENS_LIST:VALUE[D4]←DIMENS_LIST:VALUE[D5];
DIMENS_LIST:VALUE[D5]←ITEMP;
β;
D4←DIMENS_LIST:NEXT[D4];
β;
D5←DIMENS_LIST:NEXT[D5];
β;
D5←DIMENS_LIST:NEXT[D2];
WHILE D5≠NULL_RECORD DO
α D4←DIMENS_LIST:NEXT[D5];
WHILE D4≠NULL_RECORD DO
α INTEGER ITEMP;
IF DIMENS_LIST:VALUE[D5]>DIMENS_LIST:VALUE[D4] THEN
α
ITEMP←DIMENS_LIST:VALUE[D4];
DIMENS_LIST:VALUE[D4]←DIMENS_LIST:VALUE[D5];
DIMENS_LIST:VALUE[D5]←ITEMP;
β;
D4←DIMENS_LIST:NEXT[D4];
β;
D5←DIMENS_LIST:NEXT[D5];
β;
DIMEN_NUM←DIMEN_NUM+1;
COMBINE(DIMEN_DEFS[DIMEN_NUM],DIMEN_DEFS2[DIMEN_NUM],DIMENS_LIST:NEXT[D1],
DIMENS_LIST:NEXT[D2],NULL_RECORD,NULL_RECORD);
REJECT←TRUE;
β;
! abort_P;
procedure abort_P;
α ! PRINT/ABORT/PAUSE STATEMENT FOUND;
IF EQU(TOKEN,"PAUSE") THEN
α
GET_TOKEN;
IF TYPE_OF_TOKEN≠numeric_token then F_STATE(0,1102,
"Need a numeric value here for a PAUSE statement.");
PRINT("(PAUSE "&TOKEN&")");
β
ELSE α
PRINT("("&TOKEN&" ");
SPACING←SPACING+1;
GET_TOKEN;
IF ¬EQU(TOKEN,"(") THEN
ERROR(1104,"Need left paren here, continue will insert it.");
TOKEN←",";
WHILE EQU(TOKEN,",") DO
α
GET_TOKEN;
IF TYPE_OF_TOKEN=string_token THEN PRINT(dquote&TOKEN&dquote)
ELSE α
REJECT←TRUE;
P_EXP;
β;
GET_TOKEN;
IF ¬EQU(TOKEN,",") AND ¬EQU(TOKEN,";") AND ¬EQU(TOKEN,")") THEN
ERROR_REJECT(1103,"Illegal separator. Continue"&
" will try to insert reasonable separator.");
β;
IF ¬EQU(TOKEN,")") THEN
ERROR(1104,"Need right paren here, continue will insert it.");
SPACING←SPACING-1;
PRINT(")");
β;
β;
! P_statement execution starts here;
LABL←CHANGER_HEAD; ! USUALLY NULL EXCEPT WHEN INSIDE A CHANGER.;
CHANGER_HEAD←null; LABEL_TYPE←0; GET_TOKEN;
WHILE EQU(TOKEN,"COMMENT") DO
α GARB←READ(semicolon_A_break); GET_TOKEN; β;
TRY_AGAIN:
IF TYPE_OF_TOKEN=numeric_token
THEN F_STATE(0,1,"Statement can't begin with a scalar")
ELSE IF TYPE_OF_TOKEN=string_token
THEN F_STATE(0,2,"Statement can't begin with a string")
ELSE IF TYPE_OF_TOKEN=id_token
THEN
α RECORD_POINTER (ID_LIST) POINT;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE POINT≠NULL AND ¬EQU(TOKEN,ID_LIST:NAME[POINT]) DO
POINT←ID_LIST:NEXT[POINT];
! ?????;IF POINT≠NULL AND ID_LIST:TYPE[POINT]>world_VALUE THEN
α
LABEL_TYPE←ID_LIST:TYPE[POINT];
IF ID_LIST:LABEL_USED[POINT] THEN
ERROR(22,"Label multiply defined.");
ID_LIST:LABEL_USED[POINT]←TRUE;
IF EQU(LABL,null)
THEN LABL←TOKEN&" "
ELSE ERROR(22,"Double label.");
GET_TOKEN;
IF ¬EQU(TOKEN,":") THEN
ERROR_REJECT(23,"Colon needed here. Continue will insert it.");
IF LABEL_TYPE=cm_label_VALUE THEN
α
GET_TOKEN;
REJECT←TRUE;
IF ¬EQU(TOKEN,"ON") THEN ERROR(45,"Label mismatch.");
β;
GET_TOKEN;
GO TO TRY_AGAIN;
β
ELSE IF POINT≠NULL AND ID_LIST:TYPE[POINT]≤trans_VALUE THEN
α STRING id, ID_TYPE,AS;
RECORD_POINTER(DIMENS_LIST) ID_U_DIMEN,ID_L_DIMEN;
id←TOKEN;
ID_TYPE←ID_LIST:TYPE[POINT];
ID_U_DIMEN←DIMEN_DEFS[ID_LIST:DIMEN_P[POINT]];
ID_L_DIMEN←DIMEN_DEFS2[ID_LIST:DIMEN_P[POINT]];
GET_TOKEN;
IF EQU(TOKEN,"←") THEN
α
GET_TOKEN;
IF ¬EQU(TOKEN,"←")
THEN α AS←"AS "; REJECT←TRUE; β
ELSE α AS←"PAS "; β;
PRINT("("&LABL&AS&id);
SPACING←SPACING+1;
P_EXP;
IF ID_TYPE≠EXP_TYPE THEN ERROR(121,"Type mismatch on assignment.");
CHECK("assignment statement",ID_U_DIMEN,ID_L_DIMEN,UPPER_D,LOWER_D);
SPACING←SPACING-1;
PRINT(")");
β
ELSE IF EQU(TOKEN,"<") THEN
α STRING TYPE_CLC,CLC_LAB; BOOLEAN TEMP; ! GAS FOUND;
GET_TOKEN;
TYPE_CLC←TOKEN;
IF EQU(TOKEN,"<") THEN
α
GET_TOKEN;
IF ¬EQU(TOKEN,"=") THEN
ERROR_REJECT(26,"Need = here. Continue will insert it.");
β
ELSE IF ¬EQU(TOKEN,"=") AND ¬EQU(TOKEN,"≠") THEN
F_STATE(0,27,"Bogus assignment.");
GET_TOKEN;
POINT←SYMBOL_TABLE[HASH(TOKEN,hasher)];
WHILE POINT≠NULL AND ¬EQU(ID_LIST:NAME[POINT],TOKEN) DO
POINT←ID_LIST:NEXT[POINT];
IF POINT≠NULL AND ID_LIST:TYPE[POINT]=clc_label_VALUE THEN
α
CLC_LAB←TOKEN;
GET_TOKEN;
IF ¬EQU(TOKEN,":") THEN
α
REJECT←TRUE;
TEMP←FALSE;
PRINT("("&LABL&"GAS "&id&" "&TYPE_CLC&" "&CLC_LAB&")");
β
ELSE TEMP←TRUE;
β
ELSE α
REJECT←TRUE;
CLC_LAB←T_GEN;
TEMP←TRUE;
PRINT("(CLCLAB "&CLC_LAB&")");
β;
IF TEMP THEN
α
PRINT("("&LABL&"GAS "&id&" "&TYPE_CLC&" ("&CLC_LAB&" CLC");
SPACING←SPACING+1;
P_EXP;
SPACING←SPACING-1;
PRINT("))");
β;
β;
β
ELSE IF POINT=NULL THEN F_STATE (0,24,"Undefined ID.")
ELSE F_STATE(0,25,"Can't start statement this way.");
β
ELSE IF ¬(statement_beg ≤ TYPE_OF_RES_WORD ≤ statement_end) THEN
F_STATE(0,3,"Statement can't begin with <"&TOKEN&">")
ELSE CASE TYPE_OF_RES_WORD - statement_beg OF
α
redefine xx(str)=[redefine xx_temp="str" & "_P"; xx_temp;];
statement_definitions;
β;
FLUSH:
β "P_STATEMENT";
! execution starts here;
α "execution"
COUNT ← 1000; DELIMITER_1 ← DELIMITER_2 ← 0; top_delimiters ← null_record;
TABLE1 ← ",.;:[](){}+-*/#∧∨¬⊗&≤≥<>≠=←↑→?|" & lf & cr & dquote & tab & ff & space;
SETBREAK(
word_R_break ← getbreak, TABLE1, NULL, "INRK");
SETBREAK(
non_blank_break ← getbreak, space & crlf & ff & tab, NULL, "XNRK");
SETBREAK(
word_S_break ← getbreak, TABLE1, NULL, "INSK");
SETBREAK(
close_brace_break← getbreak, "}", NULL, "ISK");
SETBREAK(
non_digit_break ← getbreak, ".0123456789", NULL, "XRK");
SETBREAK(
quote_break ← getbreak, dquote, NULL, "ISN");
SETBREAK(
semicolon_A_break← getbreak, ";", NULL, "IAK");
SETBREAK(
cr_break ← getbreak, cr, NULL, "IANK");
SETBREAK(
paren_cr_break ← getbreak, "()" & cr, NULL, "IANK");
SETBREAK(
lf_ff_break ← getbreak, lf & ff, NULL, "IANK");
SETBREAK(
semicolon_R_break ← getbreak, ";", NULL, "IRK");
SETBREAK(
omit_break ← getbreak, NULL, ";,." & ff & crlf, "I");
macro_delimiter_break ← getbreak;
DISTANCE_DIMENS←NEW_RECORD(DIMENS_LIST);
DIMENS_LIST:VALUE[DISTANCE_DIMENS]←1;
TTYUP(TRUE);
! set up input and output;
if rpgsw then
α
cmd_line ← tmpin("AL", eof);
if eof
then α usererr(0, 1, "TMPIN lost"); rpgsw ← false β
else outstr(crlf & "AL: ");
β;
if ¬rpgsw then α outstr(crlf & "*"); cmd_line ← instrl(cr) β;
BIN_file ← new_record(file); ALL_file ← new_record(file);
SEX_file ← new_record(file); T←TRUE;
while true do
α "command" define want_BAIL=[switch_setting[b_X]];
procedure process_switches(record_pointer(file) F);
α record_pointer(file_switch) swt;
swt ← file:switches[F];
while swt≠null_record do
α integer i;
for i ← 0 step 1 until switch_max do
if equ(file_switch:name[swt], switch_name[i])
then α switch_setting[i] ← true; done β;
if i > switch_max then
outstr("""" & file_switch:name[swt] & """ unknown switch"& crlf);
swt ← file_switch:next[swt]
β
β;
boolean procedure got_input(record_pointer(file) F);
α
if file:chn[F] < 0 then file:chn[F] ← getchan;
open(file:chn[F], file:device[F], file:mode[F], file:in_bfrs[F],
file:out_bfrs[F], count, brchar, eof);
if eof then
α release(file:chn[F]); file:chn[F] ← -1; return(false) β;
infile ← make_file_name(F);
lookup(file:chn[F], infile, eof);
if eof ∧ length(file:ext[F])=0 ∧ length(file:def_ext[f])≠0 then
α "try default"
file:ext[F] ← file:def_ext[F];
infile ← make_file_name(F);
lookup(file:chn[F], infile, eof);
β "try default";
process_switches(F);
return(¬eof)
β;
boolean procedure got_output(record_pointer(file) F);
α
if file:chn[F] < 0 then file:chn[F] ← getchan;
open(file:chn[F], file:device[F], file:mode[F], file:in_bfrs[F],
file:out_bfrs[F], count, brchar, eof);
if eof then
α release(file:chn[F]); file:chn[F] ← -1; return(false) β;
if length(file:ext[F])=0 then file:ext[F] ← file:def_ext[F];
outfile ← make_file_name(F);
enter(file:chn[F], outfile, file:eof[F]); process_switches(F);
return(¬eof)
β;
want_BAIL ← false;
if ¬T then α outstr(crlf & "*"); cmd_line ← instrl(cr) β; T ← false;
AL_file ← scan_command(cmd_line, BIN_file, ALL_file);
if file:eof[AL_file] then
α usererr(0, 1, "null input spec"); continue "command" β;
! there was a special check for input named "DISPLAY" ;
file:mode[AL_file] ← 0; file:in_bfrs[AL_file] ← 12; file:out_bfrs[AL_file] ← 0;
file:def_ext[AL_file] ← "AL";
if ¬got_input(AL_file) then
α outstr(infile & "file not found"); continue "command" β;
copy_file_record(SEX_file, BIN_file);
file:mode[SEX_file] ← 0; file:in_bfrs[SEX_file] ← 0;
file:out_bfrs[SEX_file] ← 12; file:ext[SEX_file] ← "SEX";
if file:eof[SEX_file] then
α "null output spec"
file:device[SEX_file] ← "DSK";
file:name[SEX_file] ← file:name[AL_file]
β "null output spec";
if ¬got_output(SEX_file) then
α usererr(0, 1, "can't get output"); continue "command" β;
chanin ← file:chn[AL_file]; chanout ← file:chn[SEX_file];
pagenum ← linenum ← sourcelvl ← 0; outstr(infile & " 1"); typed_page_num ← true;
ifc debug_compile thenc if want_BAIL then BAIL; endc
done "command"
β "command";
! set up predefined constants and variables;
FOR I←1 STEP 1 UNTIL const_count DO
α RECORD_POINTER (ID_LIST) TEMP; INTEGER INDEX;
TEMP←NEW_RECORD(ID_LIST);
ID_LIST:NAME[TEMP]←PRECONST[I];
ID_LIST:TYPE[TEMP]←PRECONST_TYPE[I];
ID_LIST:DIMEN_P[TEMP]←PRE_DIMENS[I];
INDEX←HASH(PRECONST[I],hasher);
ID_LIST:NEXT[TEMP]←SYMBOL_TABLE[INDEX];
SYMBOL_TABLE[INDEX]←TEMP;
β;
! SET UP PREDEFINED DIMENSIONS;
FOR I←1 STEP 1 UNTIL (dimen_num ← metric_max) DO
DIMENS_LIST:VALUE[DIMEN_DEFS[I] ← NEW_RECORD(DIMENS_LIST)] ← I;
! PARSE PROGRAM;
spacing ← 0; print("(PR"); SPACING ← 1; BLOCK_LEVEL←0;
! **********; P_STATEMENT; ! **********;
IF TOP_SOURCE≠NULL_RECORD OR ¬EQU(INPUT(CHANIN,omit_break),null) THEN
ERROR(200,"Misc. garbage found after last end.");
spacing ← 0; print(")");
! CLEAN UP;
IF CHANIN≠-1 THEN RELEASE(CHANIN);
WHILE TOP_SOURCE≠NULL DO
α
IF SOURCE_LIST:CHAN[TOP_SOURCE]≠-1 THEN RELEASE(SOURCE_LIST:CHAN[TOP_SOURCE]);
TOP_SOURCE←SOURCE_LIST:NEXT[TOP_SOURCE];
β;
CLOSO(CHANOUT);
β "execution";
α "swap" integer array swap[0:10]; string s; integer tmperr;
if length(file:ext[BIN_file])=0 then file:ext[BIN_file] ← "BIN";
s ← make_file_name(BIN_file) & "," & make_file_name(ALL_file) & "←" & outfile;
α "switches_for_ALC" boolean seen_one; integer i;
seen_one ← false;
for i ← 0 step 1 until switch_max do
if switch_setting[i] then
α
if ¬seen_one then α s ← s & "("; seen_one ← true β;
s ← s & switch_name[i];
β;
if seen_one then s ← s & ")";
β "switches_for_ALC";
tmpout("ALC", s, tmperr);
if tmperr then usererr(0, 1, "Trouble with TMPOUT");
outstr(crlf);
swap[0] ← cvsix("DSK"); swap[1] ← cvfil("ALC.DMP[HAL,HE]", swap[2], swap[4]);
swap[3] ← 1; ! start job in RPG mode; swap[5] ← 0;
call(location(swap[0]), "SWAP");
β "swap";
β "hidden_parse";
hidden_parse;
END "PARSE";